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