From: charlie
Subject: Lispy LTK dialog builder macro
Date:
Message-ID: <1116515177.832636.224070@g43g2000cwa.googlegroups.com>
Hi,
I've been using ltk a bit now and I thought it might be nice to
have a more lispy way to define dialogs and then embed these dialogs in
others created with the same macro. I think I have mostly achieved this
simple aim but I'm sure there are many limitations and ways to break
it.
Here's a simple syntax diagram:
(def-ltk-dialog-class <dialog-name> <dialog>)
dialog => (<ltk-class-name | ltk-dialog-class-name> <slot-name>
[(configure [:option value]+)] [(pack :option value)] dialog*)
the def-ltk-dialog-class expands into a class:
(defclass <dialog-name>
((slot-name :accessor slot-name ...)*))
with an (initialize-instance :after ((dialog-name dialog-name)) &key)
and a (pack ((dialog-name dialog-name)) &key) method for embedding
ltk-dialog-classes within each other.
The end of the attached file contains a simple example.
Comments/suggestions/bugs are more than welcome.
Current limitations bugs (that I've come across so far):
The outer dialog *must* be named otherwise the pack method will try to
access a gensym that does not name a slot.
Only packing is supported, no grid layouts please.
No configuration of items (e.g. lines on a canvas that use
item-configure rather than configure)
No (with-ltk-dialog dialog ...) macro for convenience and dynamism.
Despite this I think it may be useful to a few people.
Enjoy!
Charlieb.
--- LTK-COMPOSITE.LISP ---
(defpackage "LTK-COMPOSITE"
(:use "COMMON-LISP" "LTK")
(:export "DEF-LTK-DIALOG-CLASS"
"TEST"))
(in-package :ltk-composite)
(defclass composite-widget ()
((master :accessor master :initarg :master :initform nil)))
(defmacro def-ltk-dialog-class (name dialog)
(let ((elements (get-options dialog))
(prev-element nil))
`(progn
(defclass ,name (composite-widget)
,(remove-if-not
(lambda (slot) (find-symbol (symbol-name (car slot))))
(mapcar (lambda (var) `(,(cadr var) :accessor ,(cadr var)))
elements)))
(defmethod initialize-instance :after ((,name ,name) &key)
(let* ,(mapcar (lambda (var)
`(,(cadr var) (make-instance ',(car var)
:master ,(if (caddr var)
(caddr var)
`(master ,name)))))
elements)
;; Set class vars to lets
,@(mapcar (lambda (var)
`(setf (,(cadr var) ,name) ,(cadr var)))
(remove-if-not (lambda (var)
(find-symbol (symbol-name (cadr var))))
elements))
;; Pack elements
,@(mapcar (lambda (var) `(pack ,(cadr var) ,@(cadddr var)))
(reverse (cdr elements)))
;; Optional configuration
,@(mapcar (lambda (var)
`(configure ,(cadr var) ,@(nth 4 var)))
(remove-if-not (lambda (var) (nth 4 var)) elements))
;; Special config i.e. :text :command :value
,@(mapcar (lambda (var)
(cons 'progn
(mapcar (lambda (set)
`(setf (,(car set) ,(cadr var))
,(cdr set)))
(nth 5 var))))
(remove-if-not (lambda (var) (nth 5 var)) elements))))
(defmethod pack ((,name ,name) &key (side :top) (fill :none)
expand after before padx pady ipadx ipady anchor)
(pack (,(print (cadar elements)) ,name)
:side side
:fill fill
:expand expand
:after after
:before before
:padx padx
:pady pady
:ipadx ipadx
:ipady ipady
:anchor anchor)))))
(defun get-options (dialog &optional master accum)
(let ((type (car dialog))
(name (if (atom (cadr dialog)) (cadr dialog) (gensym)))
(elements (if (atom (cadr dialog)) (cddr dialog) (cdr dialog)))
(pack-options)
(configure-options)
(special-options))
(dolist (element elements (cons (list type
name
master
pack-options
configure-options
special-options) accum))
(case (car element)
(pack (setq pack-options (cdr element)))
(configure (multiple-value-bind (config special)
(process-configure element)
(setq configure-options (append config configure-options))
(setq special-options (append special special-options))))
(t (setq accum (get-options element name accum)))))))
(defun process-configure (conf)
(let (config special)
(loop for conf-item = (cdr conf)
then (cddr conf-item)
until (null conf-item) do
(if (member (car conf-item) '(:command :text :value))
(push (cons (case (car conf-item)
(:command 'command)
(:text 'text)
(:value 'value))
(cadr conf-item))
special)
(setq config (append config
(list (car conf-item) (cadr conf-item))))))
(values config special)))
(defun test ()
(let ((dialog '(toplevel top
(frame fr1
(button b1
(configure :command
(lambda () (print 'b1))))
(button b2
(configure :colour :blue)
(pack :side :left)))
(fr (label l2)))))
(print (get-options dialog))
(print (macroexpand-1 `(def-ltk-dialog test ,dialog)))
(with-ltk (make-instance 'player))
))
(def-ltk-dialog-class player-buttons
(frame player-button-frame
(button back
(configure :text "|<")
(pack :side :left))
(button rew
(configure :text "<<")
(pack :side :left))
(button play-pause
(configure :text "||>")
(pack :side :left))
(button ff
(configure :text ">>")
(pack :side :left))
(button next
(configure :text ">|")
(pack :side :left))))
(def-ltk-dialog-class player
(toplevel (canvas screen)
(player-buttons buttons)))