[ltk-user] LTK improvements
Jan Rychter
jan at rychter.com
Tue Nov 28 09:28:28 EST 2006
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.
-------------- next part --------------
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 at 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
More information about the ltk-user
mailing list