I have a fairly large bunch of changes to ltk, mostly having to do with the text widget, but also with support for new widgets from the BWidget toolkit (such as tree). I am not completely happy with these changes, as I am sure they require further work and/or review. They can likely be implemented much better. But since I haven't found the time to do so over the last 2 months, I thought I'd rather push them out, to prevent wasting of time in case somebody is doing the same thing in parallel. Should I send the diffs to the list, or directly to Peter? Please note, they definitely do require reviewing. --J.
Hello Jan, I would be interested to know this too as I've also been adding to the text widget (although only on a very small scale so far). Your code's probably better than mine! Phil On 11/27/06, Jan Rychter <jan@rychter.com> wrote:
I have a fairly large bunch of changes to ltk, mostly having to do with the text widget, but also with support for new widgets from the BWidget toolkit (such as tree).
I am not completely happy with these changes, as I am sure they require further work and/or review. They can likely be implemented much better. But since I haven't found the time to do so over the last 2 months, I thought I'd rather push them out, to prevent wasting of time in case somebody is doing the same thing in parallel.
Should I send the diffs to the list, or directly to Peter? Please note, they definitely do require reviewing.
--J. _______________________________________________ ltk-user site list ltk-user@common-lisp.net http://common-lisp.net/mailman/listinfo/ltk-user
On 11/27/06, Jan Rychter <jan@rychter.com> wrote:
I have a fairly large bunch of changes to ltk, mostly having to do with the text widget, but also with support for new widgets from the BWidget toolkit (such as tree).
I am not completely happy with these changes, as I am sure they require further work and/or review. They can likely be implemented much better. But since I haven't found the time to do so over the last 2 months, I thought I'd rather push them out, to prevent wasting of time in case somebody is doing the same thing in parallel.
Should I send the diffs to the list, or directly to Peter? Please note, they definitely do require reviewing.
I would recommend to send them out to the list - if they require some more work, then everyone who reads the list may volunteer to do that work, and in general, they might serve as starting points for other Ltk users. If you want them included into Ltk, please attach your copyright notice and a statement about releasing them under LLGPL, so that I can use them without legal headaches. Peter
Ok, here goes. The full diff against 0.90 is attached below, comments and notes follow. BWidget changes: -- added BWidget tree (not yet fully featured, but close, all callbacks need to be implemented) -- added raisecmd option to notebook widget's insert-page method -- added configure-page to the notebook widget -- tried to implement LabelEntry, not yet complete Text widget changes: -- added :position and :padx keyword args to insert-object, this is very useful in the text widget -- improved append-text so that it deals with empty text, removed unnecessary space, -- added insert-text, supporting :position and :tags arguments, NOTE this needs work, I'm assuming a list of tags gets passed, not a single tag, it should probably support both, -- made insert-object accept :padx and :position arguments, -- added tag and mark commands, these should be fairly complete, -- added dump and index methods -- added text-image-create method Other Ltk changes: -- minor formatting changes in ltk.lisp (spaces before parentheses, etc) -- added callback6 to ltk.lisp, and I really think there should be a better way of dealing with multi-parameter callbacks... -- introduced dependencies: split-sequence, cl-ppcre, iterate: these probably aren't all strictly necessary, but I really hate to reinvent the wheel, and those are all good quality libraries, so... I have high hopes for the open source fairy to make my code better now. --J. diff -ur ltk-0.90-original/BWidget.lisp ltk-0.90/BWidget.lisp --- ltk-0.90-original/BWidget.lisp 2006-07-15 16:45:14.000000000 +0200 +++ ltk-0.90/BWidget.lisp 2006-10-05 16:45:51.000000000 +0200 @@ -43,6 +43,7 @@ (defpackage :bwidget (:use :common-lisp :ltk + :iterate ) (:export #:note-book-page @@ -51,11 +52,35 @@ #:insert-page #:delete-page #:raise-page + #:configure-page + #:tree + #:tree-node + #:insert-node + #:get-node-data + #:set-node-data + #:get-node-text + #:set-node-text + #:edit-node + #:bind-text + #:bind-image + #:close-tree + #:open-tree + #:selection-get + #:selection-set + #:see + #:index + #:parent + #:visible + #:exists + #:move-tree-node + #:delete-all + #:open-all + #:labelentry )) (in-package :bwidget) -(eval-when (:load-toplevel) +(eval-when (:compile-toplevel :load-toplevel :execute) (setf *init-wish-hook* (append *init-wish-hook* (list (lambda () (send-wish "package require BWidget") @@ -84,17 +109,21 @@ borderwidth disabledforeground foreground repeatdelay repeatinterval arcradius height homogeneous side tabbevelsize tabpady width)) -(defmethod insert-page ((nb note-book) index &key text) - (let ((page-name (ltk::create-name))) - (format-wish "senddata [~a insert ~a ~a ~@[ -text {~A}~]]" - (widget-path nb) index page-name text) +;; todo: createcmd leavecmd image +(defmethod insert-page ((nb note-book) index &key text raisecmd) + (let ((page-name (ltk::create-name)) + (raise-callback (when raisecmd (ltk::create-name)))) + (when raisecmd (ltk::add-callback raise-callback raisecmd)) + (format-wish "senddata [~a insert ~a ~a ~@[ -text {~A}~]~ + ~@[ -raisecmd {callback ~a}~]]" + (widget-path nb) index page-name text raise-callback) (let ((path (ltk::read-data))) (if path (make-instance 'note-book-page :page-name page-name :note-book nb :path (string-downcase path)) - (error "error while inserting page"))))) + (error "error while inserting page"))))) (defmethod raise-page ((nbp note-book-page)) (format-wish "~a raise ~a" (widget-path (note-book nbp)) (page-name nbp))) @@ -105,4 +134,180 @@ (defmethod compute-size ((nb note-book)) (format-wish "~a compute_size" (widget-path nb))) +(defmethod configure-page ((nbp note-book-page) &key text raisecmd) + (let ((page-name (page-name nbp)) + (raise-callback (when raisecmd (ltk::create-name)))) + (when raisecmd (ltk::add-callback raise-callback raisecmd)) + (format-wish "~a itemconfigure ~a ~@[ -text {~A}~]~ + ~@[ -raisecmd {callback ~a}~]" + (widget-path (note-book nbp)) page-name text raise-callback))) + + +(defclass tree (widget) + ()) + +(defmethod initialize-instance :after ((tree tree) &key deltax deltay padx + background selectbackground selectforeground + selectcommand width height selectfill showlines + linesfill linestipple crossfill redraw + opencmd closecmd dropovermode + crossopenimage crosscloseimage crossopenbitmap + crossclosebitmap + dragenabled draginitcmd dragendcmd dragtype + dragevent dropenabled dropcmd) + (let* ((drop-command-name (ltk::create-name)) + (drop-command (when dropcmd drop-command-name))) + (ltk::add-callback drop-command-name dropcmd) + (format-wish "Tree ~a ~@[ -deltax ~(~A~)~]~ + ~@[ -deltay ~(~A~)~]~@[ -padx ~(~A~)~]~ + ~@[ -background ~(~A~)~]~@[ -selectbackground ~(~A~)~]~ + ~@[ -selectforeground ~(~A~)~]~@[ -selectcommand ~(~A~)~]~ + ~@[ -width ~(~A~)~]~@[ -height ~(~A~)~]~ + ~@[ -selectfill ~(~A~)~]~@[ -showlines ~(~A~)~]~@[ -linesfill ~(~A~)~]~ + ~@[ -linestipple ~(~A~)~]~@[ -crossfill ~(~A~)~]~@[ -redraw ~(~A~)~]~ + ~@[ -opencmd ~(~A~)~]~@[ -closecmd ~(~A~)~]~@[ -dropovermode ~(~A~)~]~ + ~@[ -crossopenimage ~(~A~)~]~@[ -crosscloseimage ~(~A~)~]~ + ~@[ -crossopenbitmap ~(~A~)~]~@[ -crossclosebitmap ~(~A~)~]~ + ~@[ -dragenabled ~(~A~)~]~@[ -draginitcmd ~(~A~)~]~ + ~@[ -dragendcmd ~(~A~)~]~@[ -dragtype ~(~A~)~]~ + ~@[ -dragevent ~(~A~)~]~@[ -dropenabled ~(~A~)~]~@[ -dropcmd {callback6 ~A}~]" + (widget-path tree) + deltax deltay padx + background selectbackground selectforeground + selectcommand width height selectfill showlines + linesfill linestipple crossfill redraw + opencmd closecmd dropovermode + crossopenimage crosscloseimage crossopenbitmap + crossclosebitmap + dragenabled draginitcmd dragendcmd dragtype + dragevent dropenabled drop-command))) + +;; drop + +;; FIXME: callbacks: +;; selectcommand opencmd closecmd draginitcmd dragendcmd + +(defmethod insert-node ((tree tree) index parent node-name + &key text font image window fill data + open selectable drawcross padx + deltax anchor) + (format-wish "~a insert ~(~a~) ~(~a~) ~(~a~)~ + ~@[ -text {~A}~]~ + ~@[ -font ~(~A~)~]~@[ -image ~(~A~)~]~ + ~@[ -window ~(~A~)~]~@[ -fill ~(~A~)~]~ + ~@[ -data {~A}~]~@[ -open ~(~A~)~]~ + ~@[ -selectable ~(~A~)~]~@[ -drawcross ~(~A~)~]~ + ~@[ -padx ~(~A~)~]~@[ -deltax ~(~A~)~]~@[ -anchor ~(~A~)~]" + (widget-path tree) index parent node-name + text font image window fill data + open selectable drawcross padx + deltax anchor)) + +(defmethod get-node-data ((tree tree) node-name) + (format-wish "senddatastring [~a itemcget ~(~a~) -data]" + (widget-path tree) node-name) + (ltk::read-data)) + +(defmethod set-node-data ((tree tree) node-name data) + (format-wish "~a itemconfigure ~(~a~) -data \"~a\"" + (widget-path tree) node-name (ltk::tkescape data))) + +(defmethod get-node-text ((tree tree) node-name) + (format-wish "senddatastring [~a itemcget ~(~a~) -text]" + (widget-path tree) node-name) + (ltk::read-data)) + +(defmethod edit-node ((tree tree) node-name text) + (format-wish "senddatastring [~a edit ~(~a~) \"~a\"]" + (widget-path tree) node-name (ltk::tkescape text)) + (ltk::read-data)) + +(defmethod set-node-text ((tree tree) node-name text) + (format-wish "~a itemconfigure ~(~a~) -text \"~a\"" + (widget-path tree) node-name (ltk::tkescape text))) + +(defmethod selection-get ((tree tree)) + (format-wish "senddatastring [~a selection get]" + (widget-path tree)) + (ltk::tcl-string-to-list (ltk::read-data))) + +(defmethod selection-set ((tree tree) node) + (format-wish "~a selection set ~(~a~)" (widget-path tree) node)) + + +(defmethod bind-text ((tree tree) event fun) + (let ((name (ltk::create-name))) + (ltk::add-callback name fun) + (format-wish "~a bindText ~a {callbackstring ~a}" + (widget-path tree) + event + name)) + tree) + +(defmethod bind-image ((tree tree) event fun) + (let ((name (ltk::create-name))) + (ltk::add-callback name fun) + (format-wish "~a bindText ~a {callback ~a}" + (widget-path tree) + event name)) + tree) + +(defmethod close-tree ((tree tree) node-name &key (recurse t)) + (format-wish "~a closetree ~(~a~) ~a" (widget-path tree) + node-name (if recurse "true" "false"))) + +(defmethod open-tree ((tree tree) node-name &key (recurse t)) + (format-wish "~a opentree ~(~a~) ~a" (widget-path tree) node-name (if recurse "true" "false"))) + +(defmethod open-all ((tree tree)) + (format-wish "senddatastring [~a nodes root]" (widget-path tree)) + (let ((nodes (ltk::tcl-string-to-list (ltk::read-data)))) + (iterate (for node in nodes) + (format-wish "~a opentree ~(~a~)" (widget-path tree) node)))) + +(defmethod see ((tree tree) node-name) + (format-wish "~a see ~(~a~)" (widget-path tree) node-name)) + +(defmethod index ((tree tree) node-name) + (format-wish "senddatastring [~a index ~(~a~)]" + (widget-path tree) node-name) + (ltk::read-data)) + +(defmethod parent ((tree tree) node-name) + (format-wish "senddatastring [~a parent ~(~a~)]" + (widget-path tree) node-name) + (ltk::read-data)) + +(defmethod visible ((tree tree) node-name) + (format-wish "senddatastring [~a visible ~(~a~)]" + (widget-path tree) node-name) + (ltk::read-data)) + +(defmethod exists ((tree tree) node-name) + (format-wish "senddatastring [~a exists ~(~a~)]" + (widget-path tree) node-name) + (ltk::read-data)) + +(defmethod move-tree-node ((tree tree) new-parent node-name index) + (format-wish "senddatastring [~a move ~(~a~) ~(~a~) ~(~a~)]" + (widget-path tree) new-parent node-name index)) + +(defmethod delete-all ((tree tree)) + (format-wish "~a delete [~a nodes root]" + (widget-path tree) (widget-path tree))) + +;; TODO: implement: +;; reorder nodes edit delete configure +;; fix commands to be proper callbacks + + +(defclass labelentry (entry) + ()) + +(defmethod initialize-instance :before ((w labelentry) &key &allow-other-keys) + (setf (ltk::widget-class-name w) "LabelEntry")) + + +(defmethod initialize-instance :after ((w labelentry) &key &allow-other-keys) + #-(and)(setf (ltk::widget-class-name w) "LabelEntry")) diff -ur ltk-0.90-original/ltk.asd ltk-0.90/ltk.asd --- ltk-0.90-original/ltk.asd 2006-07-15 16:45:14.000000000 +0200 +++ ltk-0.90/ltk.asd 2006-09-26 09:56:12.000000000 +0200 @@ -13,6 +13,9 @@ :licence "LGPL" :description "LTK" :long-description "Lisp bindings for the Tk toolkit" - :components ((:file "ltk")) + :components ((:file "ltk") + (:file "ltk-tile" :depends-on ("ltk")) + (:file "BWidget" :depends-on ("ltk"))) + :depends-on (#:cl-ppcre #:iterate #:split-sequence) ) diff -ur ltk-0.90-original/ltk.lisp ltk-0.90/ltk.lisp --- ltk-0.90-original/ltk.lisp 2006-07-15 16:45:13.000000000 +0200 +++ ltk-0.90/ltk.lisp 2006-10-01 20:00:41.000000000 +0200 @@ -1,4 +1,4 @@ -#| +a#| This software is Copyright (c) 2003, 2004, 2005, 2006 Peter Herth <herth@peter-herth.de> Parts Copyright (c) 2005 Thomas F. Burdick @@ -120,10 +120,11 @@ (defpackage :ltk - (:use :common-lisp - #+(or :cmu :scl) :ext - #+:sbcl :sb-ext - ) + (:use :common-lisp + #+(or :cmu :scl) :ext + #+:sbcl :sb-ext + :split-sequence + ) (:export #:ltktest #:*ltk-version* #:*cursors* @@ -144,6 +145,7 @@ #:after-cancel #:after-idle #:append-text + #:insert-text #:append-newline #:ask-okcancel #:ask-yesno @@ -314,6 +316,9 @@ #:set-wm-overrideredirect #:spinbox #:start-wish + #:tag-add + #:tag-remove + #:tag-names #:tag-bind #:tag-configure #:text @@ -497,6 +502,7 @@ (send-wish "proc callback {s} {puts \"(:callback \\\"$s\\\")\";flush stdout} ") (send-wish "proc callbackval {s val} {puts \"(:callback \\\"$s\\\" $val)\"} ") + (send-wish "proc callback6 {s v1 v2 v3 v4 v5 v6} {puts \"(:callback \\\"$s\\\" \\\"$v1\\\" \\\"$v2\\\" \\\"$v3\\\" \\\"$v4\\\" \\\"$v5\\\" \\\"$v6\\\")\"} ") (send-wish "proc callbackstring {s val} {puts \"(:callback \\\"$s\\\" \\\"[escape $val]\\\")\"} ") (dolist (fun *init-wish-hook*) ; run init hook funktions @@ -1351,7 +1357,7 @@ ;;; menues -(defclass menu(widget) +(defclass menu (widget) ((text :accessor text :initarg :text) (help :accessor menu-help :initarg :help :initform nil) )) @@ -1367,7 +1373,7 @@ (format-wish "~A add cascade -label {~A} -menu ~a~@[ -underline ~a ~]" (widget-path (master m)) (text m) (widget-path m) underline))) -(defun make-menu(menu text &key underline name) +(defun make-menu (menu text &key underline name) (if name (make-instance 'menu :master menu :text text :underline underline :name name) (make-instance 'menu :master menu :text text :underline underline))) @@ -1378,7 +1384,7 @@ ;;; menu button -(defclass menubutton(widget) +(defclass menubutton (widget) ((text :accessor text :initarg :text :initform "") )) @@ -1388,12 +1394,12 @@ (format-wish "~A add command -label {~A} -command {callback ~A}~@[ -underline ~a ~]~@[ -accelerator {~a} ~]" (widget-path (master m)) (text m) (name m) underline accelerator)) -(defun make-menubutton(menu text command &key underline accelerator) +(defun make-menubutton (menu text command &key underline accelerator) (let* ((mb (make-instance 'menubutton :master menu :text text :command command :underline underline :accelerator accelerator))) mb)) -(defclass menucheckbutton(widget) +(defclass menucheckbutton (widget) ((text :accessor text :initarg :text) (command :accessor command :initarg :command :initform nil))) @@ -1411,7 +1417,7 @@ (format-wish "set ~a ~a" (name cb) val) val) -(defclass menuradiobutton(widget) +(defclass menuradiobutton (widget) ((text :accessor text :initarg :text) (command :accessor command :initarg :command :initform nil) (group :accessor group :initarg :group :initform nil))) @@ -1677,9 +1683,12 @@ (defmethod (setf text) (new-text (self scrolled-text)) (setf (text (textbox self)) new-text)) -(defgeneric insert-object (txt object)) -(defmethod insert-object ((txt scrolled-text) obj) - (format-wish "~a window create end -window ~a" (widget-path (textbox txt)) (widget-path obj)) +(defgeneric insert-object (txt obj &key position padx)) +(defmethod insert-object ((txt scrolled-text) obj &key (position :insert) padx) + (format-wish "~a window create ~(~a~) ~@[ -padx ~(~a~)~] -window ~a" + (widget-path (textbox txt)) + position padx + (widget-path obj)) txt) (defgeneric see (txt pos)) @@ -2148,11 +2157,19 @@ (make-instance 'text :master master :width width :height height)) (defmethod append-text ((txt text) text &rest tags) - (format-wish "~a insert end \"~a\" {~{ ~(~a~)~}}" (widget-path txt) (tkescape text) tags) + (format-wish "~a insert end \"~a\" ~@[{~{~(~a~)~}}~]" (widget-path txt) (tkescape text) tags) + txt) + +(defmethod insert-text ((txt text) text &key tags (position :insert)) + (format-wish "~a insert ~(~a~) \"~a\" ~@[{~{~(~a~) ~}}~]" + (widget-path txt) position (tkescape text) tags) txt) -(defmethod insert-object ((txt text) obj) - (format-wish "~a window create end -window ~a" (widget-path txt) (widget-path obj)) +(defmethod insert-object ((txt text) obj &key (position :insert) padx) + (format-wish "~a window create ~(~a~) ~@[ -padx ~(~a~)~] -window ~a" + (widget-path txt) + position padx + (widget-path obj)) txt) (defun append-newline (text) @@ -2163,16 +2180,45 @@ (format-wish "~A delete 0.0 end" (widget-path txt)) txt) -(defmethod see((txt text) pos) +(defmethod see ((txt text) pos) (format-wish "~a see ~a" (widget-path txt) pos) txt) +;;; tags + +(defun tag-to-string (tag) + "Convert a lisp-side tag to a string, return the resulting string" + (if (stringp tag) + tag + (if tag + (format nil "~(~a~)" tag) + ""))) + +(defun tcl-string-to-list (str) + "Convert a TCL string with a list of items to a list of strings." + (loop for item in (cl-ppcre:all-matches-as-strings "(\\w+)|({[\\w\\s]+})" str) + collect (cl-ppcre:regex-replace "^{([\\w\\s]+)}$" item "\\1"))) + +(defgeneric tag-add (txt tag &rest indices)) +(defmethod tag-add ((txt text) tag &rest indices) + (format-wish "~a tag add ~a ~{ ~(~a~)~}" + (widget-path txt) + (tag-to-string tag) + indices) + txt) + +(defgeneric tag-remove (txt tag &rest indices)) +(defmethod tag-remove ((txt text) tag &rest indices) + (format-wish "~a tag remove ~a ~{ ~(~a~)~}" + (widget-path txt) + (tag-to-string tag) + indices) + txt) + (defgeneric tag-configure (txt tag option value)) (defmethod tag-configure ((txt text) tag option value) (format-wish "~a tag configure ~a -~(~a~) {~(~a~)}" (widget-path txt) - (if (stringp tag) - tag - (format nil "~(~a~)" tag)) + (tag-to-string tag) option value) txt) @@ -2181,10 +2227,113 @@ "bind fun to event of the tag of the text widget txt" (let ((name (create-name))) (add-callback name fun) - (format-wish "~a tag bind ~a ~a {callback ~A}" (widget-path txt) tag event name) - ) + (format-wish "~a tag bind ~(~a~) ~a {callback ~A}" + (widget-path txt) (tag-to-string tag) + event name)) + txt) + +(defgeneric tag-delete (txt tag &rest other-tags)) +(defmethod tag-delete ((txt text) tag &rest other-tags) + (format-wish "~a tag delete ~a ~{ ~(~a~)~}" + (widget-path txt) + (tag-to-string tag) + (mapcar #'tag-to-string other-tags)) + txt) + +(defgeneric tag-lower (txt tag &optional other-tag)) +(defmethod tag-lower ((txt text) tag &optional other-tag) + (format-wish "~a tag lower ~a ~a" + (widget-path txt) + (tag-to-string tag) + (tag-to-string other-tag)) txt) +(defgeneric tag-raise (txt tag &optional other-tag)) +(defmethod tag-raise ((txt text) tag &optional other-tag) + (format-wish "~a tag raise ~a ~a" + (widget-path txt) + (tag-to-string tag) + (tag-to-string other-tag)) + txt) + +(defgeneric tag-names (txt index)) +(defmethod tag-names ((txt text) index) + (format-wish "senddatastring [~a tag names ~(~a~)]" + (widget-path txt) + index) + (tcl-string-to-list (read-data))) + +(defgeneric tag-nextrange (txt tag index1 &optional index2)) +(defmethod tag-nextrange ((txt text) tag index1 &optional index2) + (format-wish "senddatastring [~a tag nextrange ~a ~(~a~) ~(~a~)]" + (widget-path txt) + (tag-to-string tag) + index1 + (if index2 index2 "")) + (tcl-string-to-list (read-data))) + +(defgeneric tag-prevrange (txt tag index1 &optional index2)) +(defmethod tag-prevrange ((txt text) tag index1 &optional index2) + (format-wish "senddatastring [~a tag nextrange ~a ~(~a~) ~(~a~)]" + (widget-path txt) + (tag-to-string tag) + index1 + (if index2 index2 "")) + (tcl-string-to-list (read-data))) + +(defgeneric tag-ranges (txt tag)) +(defmethod tag-ranges ((txt text) tag) + (format-wish "senddatastring [~a tag ranges ~a]" (widget-path txt) (tag-to-string tag)) + (tcl-string-to-list (read-data))) + +;;; marks + +(defgeneric mark-gravity ((txt text) mark direction)) +(defmethod mark-gravity ((txt text) mark direction) + (format-wish "~a mark gravity ~a ~(~a~)" (widget-path txt) (tag-to-string mark) direction)) + +(defgeneric mark-names ((txt text))) +(defmethod mark-names ((txt text)) + (format-wish "senddatastring [~a mark names]" (widget-path txt)) + (tcl-string-to-list (read-data))) + +(defgeneric mark-next ((txt text) index)) +(defmethod mark-next ((txt text) index) + (format-wish "senddatastring [~a mark next ~(~a~)]" (widget-path txt) index) + (read-data)) + +(defgeneric mark-previous ((txt text) index)) +(defmethod mark-previous ((txt text) index) + (format-wish "senddatastring [~a mark previous ~(~a~)]" (widget-path txt) index) + (read-data)) + +(defgeneric mark-set ((txt text) mark index)) +(defmethod mark-set ((txt text) mark index) + (format-wish "~a mark set ~a ~(~a~)" (widget-path txt) (tag-to-string mark) index)) + +(defgeneric mark-unset ((txt text) mark &optional other-marks)) +(defmethod mark-unset ((txt text) mark &optional other-marks) + (format-wish "~a mark unset ~a~{ ~a~}" + (widget-path txt) + (tag-to-string mark) + (mapcar #'tag-to-string other-marks))) + +;;; dumping + +(defgeneric dump ((txt text) index1 &key index2 switches)) +(defmethod dump ((txt text) index1 &key index2 switches) + (format-wish "senddatastring [~a dump ~{ -~(~a~)~} ~(~a~) ~(~a~)]" + (widget-path txt) + switches + index1 + (if index2 index2 "")) + (read-data)) + +(defgeneric index ((txt text) index)) +(defmethod index ((txt text) index) + (format-wish "senddatastring [~a index ~(~a~)]" (widget-path txt) index) + (read-data)) + (defmethod text ((text text)) (format-wish "senddatastring [~a get 1.0 end]" (widget-path text)) (read-data)) @@ -2207,9 +2356,10 @@ (format-wish "set file [open {~a} \"r\"];~a delete 1.0 end;~a insert end [read $file];close $file;puts \"(:DATA asdf)\"" filename (widget-path txt) (widget-path txt)) (read-data)) + ;;; photo image object -(defclass photo-image(tkobject) +(defclass photo-image (tkobject) () ) @@ -2238,6 +2388,14 @@ "ishow.ppm") (image-load p "ishow.ppm")) + +;; images in text +(defgeneric text-image-create (txt img index &rest options)) +(defmethod text-image-create ((txt text) (img photo-image) index &key align padx pady) + (format-wish "~a image create ~(~a~) -image ~a ~@[ -align ~a~]~@[ -padx ~a~]~@[ -pady ~a~]" + (widget-path txt) index (widget-path img) align padx pady)) + + ;;;; generic methods on widgets ;;; pack method for widget arrangement in container
"Peter" == Peter Herth <herth@peter-herth.de> writes: Peter> On 11/27/06, Jan Rychter <jan@rychter.com> wrote: I have a fairly large bunch of changes to ltk, mostly having to do with the text widget, but also with support for new widgets from the BWidget toolkit (such as tree).
I am not completely happy with these changes, as I am sure they require further work and/or review. They can likely be implemented much better. But since I haven't found the time to do so over the last 2 months, I thought I'd rather push them out, to prevent wasting of time in case somebody is doing the same thing in parallel.
Should I send the diffs to the list, or directly to Peter? Please note, they definitely do require reviewing.
Peter> I would recommend to send them out to the list - if they require Peter> some more work, then everyone who reads the list may volunteer Peter> to do that work, and in general, they might serve as starting Peter> points for other Ltk users. If you want them included into Ltk, Peter> please attach your copyright notice and a statement about Peter> releasing them under LLGPL, so that I can use them without legal Peter> headaches. The changes I sent are (C) copyright by me and I do release them under both LLGPL and BSD licenses, with a strong preference towards BSD. --J.
If you want them included into Ltk, please attach your copyright notice and a statement about releasing them under LLGPL, so that I can use them without legal headaches.
Peter, Unfortunately my additions are pitiful (but necessary for my project). That said, I grant all rights to release them under the LLGPL if you think they're OK (or can be made OK). (do you need a more formal statement than that?) (do you need them in diff format?) Many thanks for creating LTk! Phil ----------------- (defmethod selection-ranges ((text text)) (format-wish "senddatastring [~a tag ranges sel]" (widget-path text)) (read-data)) (defmethod selected-text ((text text)) (when (not (equal (selection-ranges text) "")) (format-wish "senddatastring [~a get sel.first sel.last]" (widget-path text)) (read-data)))
On 11/28/06, Phil Armitage <philip.armitage@gmail.com> wrote:
Unfortunately my additions are pitiful (but necessary for my project). That said, I grant all rights to release them under the LLGPL if you think they're OK (or can be made OK).
(do you need a more formal statement than that?) (do you need them in diff format?)
Thank you, no more formal statement is needed. While one could argue, that all contributions to Ltk must be LLGPLed by the "viral" nature of the license (as they build obviously on the LLGPLed Ltk), I just want to make sure that anyone posting additions knows and agrees, so I do not get one day into license troubles. Peter
[...]
(defmethod selection-ranges ((text text)) (format-wish "senddatastring [~a tag ranges sel]" (widget-path text)) (read-data))
Just as a side note, in my changes I've implemented: (defgeneric tag-ranges (txt tag)) (defmethod tag-ranges ((txt text) tag) (format-wish "senddatastring [~a tag ranges ~a]" (widget-path txt) (tag-to-string tag)) (tcl-string-to-list (read-data))) which you can call as (tag-ranges txt :selection) and get the ranges as a list, instead of a string (which I found inconvenient). --J.
participants (3)
-
Jan Rychter -
Peter Herth -
Phil Armitage