conservatory
/
stk
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
stk/Demos/amib.stklos

605 lines
20 KiB
Bash
Executable File
Raw Blame History

#!/bin/sh
:; exec /usr/local/bin/stk -f "$0" "$@"
;;;;
;;;; a m i b . s t k l o s -- A mini interface builder. I hope it will serve
;;;; as the basis of something more complete...
;;;;
;;;; Copyright © 1995-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions. No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 22-May-1995 14:56
;;;; Last file update: 3-Sep-1999 19:13 (eg)
(require "Tk-classes")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Definitions.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define *amib-version* 0.5)
(define *pretty-names* (make-hash-table))
(define *current-file* #f)
(define *special-slots* '("id" "eid" "parent" "environment"))
(define *delay* 100)
;;;;
;;;; All the widgets and their defaults
;;;;
(define *table-defaults*
`(("Button" ,<Button>
(:text "Button"))
("Canvas" ,<Canvas>
(:width 200 :height 100 :border-width 3 :relief "raised"))
("Check button" ,<Check-button>
(:text "Check" :anchor "w"))
("Frame" ,<Frame>
(:width 50 :height 50 :relief "ridge" :border-width 2))
("Label" ,<Label>
(:text "Label"))
("Labeled entry" ,<Labeled-entry>
(:title "Title"))
("Listbox" ,<Listbox>
(:relief raised))
("Message" ,<Message>
(:text "Message" :relief "raised" :aspect 1000))
("Radio button" ,<Radio-button>
(:text "Radio" :anchor "w"))
("Scale" ,<Scale>
()) ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Drag and Drop stuff
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define d-n-d-widget #f) ; The widget whih we can drag and drop
(define d-n-d-defaults #f) ; Its defaults
;; Default bindings
(bind "Dnd" "<ButtonRelease-1>" (lambda (|X| |Y| x y)
(Drag-n-Drop-Finish |X| |Y|)
'break))
(define (make-drag-n-drop-widget type initargs)
(let ((m (make <Toplevel> :background "Blue" :override-redirect #t)))
(pack (apply make type :parent m initargs) :padx 2 :pady 2)
m))
(define (Drag-n-Drop-Motion)
(when d-n-d-widget
(slot-set! d-n-d-widget 'geometry
(apply format #f "+~A+~A" (winfo 'pointerxy d-n-d-widget)))
(after *delay* (lambda () (Drag-n-Drop-Motion)))))
(define (Drag-n-Drop-Finish X Y)
(when d-n-d-widget
(let ((dwidth (winfo 'width d-n-d-widget))
(dheight (winfo 'height d-n-d-widget)))
;; iconify the d-n-d-widget and see on which window we depose it
(withdraw d-n-d-widget)
(let* ((p (Id->instance (winfo 'containing X Y)))
(top (Id->instance (winfo 'toplevel p))))
(when (string=? (slot-ref top 'class) "Amib-toplevel")
;; OK. We try to depose the new widget in a valid toplevel
(let* ((w (apply make (car d-n-d-defaults) :parent p
(cadr d-n-d-defaults)))
(pw (max 1 (winfo 'width p)))
(ph (max 1 (winfo 'height p)))
(x (- X (winfo 'x top) (winfo 'x p)))
(y (- Y (winfo 'y top) (winfo 'y p)))
(relw (/ dwidth pw))
(relh (/ dheight ph)))
(place w :relx (/ x pw) :rely (/ y ph) :relwidth relw :relheight relh)
(raise w)
;; Associate bindings for manipulating the new widget
(bind w "<Shift-1>" (lambda (|X| |Y|)
(widget-resize-start w |X| |Y|)
'break))
(bind w "<Button-2>" (lambda () (edit-widget w) 'break))
(bind w "<Shift-3>" (lambda () (edit-widget w) 'break)) ; for Win32
(bind w "<Button-3>" (lambda () (destroy w) 'break))))))
;; We can now delete the drag and drop window,which doesn't serve anymore
(destroy d-n-d-widget)
(set! d-n-d-widget #f)))
(define (create-new-widget lb x y Xabs Yabs)
(unless d-n-d-widget
(let* ((index (nearest lb y))
(type (list-ref (value lb) index))
(search (assoc type *table-defaults*)))
(when search
;; Create a drag and drow window and post it under the mouse
(let ((W (apply make-drag-n-drop-widget (cadr search) (cddr search))))
(set! (geometry W) (format #f "+~a+~a" Xabs Yabs))
(bindtags W (cons "Dnd" (bindtags W)))
(set! d-n-d-widget W)
(set! d-n-d-defaults (cdr search))
(after *delay* (lambda () (Drag-n-Drop-Motion))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Define a Toplevel for working
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define new-amib-toplevel
(let ((count 0))
(lambda ()
(let* ((n (* count 20))
(t (make <Toplevel> :title (format #f "Toplevel # ~A" count)
:class "Amib-toplevel"
:geometry (format #f "450x300+~A+~A" n n))))
(set! count (+ count 1))
(pack (make <Frame> :parent t :border-width 0) :expand #t :fill "both")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; build-interface -- construct the button panel
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (build-interface)
(let* ((mess (make <Label> :relief "ridge" :border-width 3 :foreground "blue"
:text (format #f "A Mini Interface Builder (V~A)"
*amib-version*)))
;; Menus
(menus `((" File "
("Load" ,load-file)
("Save" ,save-file)
("Save as" ,write-file)
("")
("Quit" ,quit))
(" Toplevel "
("Create" ,new-amib-toplevel))
0
(" Help "
("About" ,(lambda ()
(stk:show-help-file "amib-abt.html")))
("Help" ,(lambda ()
(stk:show-help-file "amib-hlp.html"))))))
;; Widget Panel
(chooser (make <Scroll-Listbox> :value (map car *table-defaults*)))
;; Menu bar
(bar (make-toolbar *top-root* menus :relief "ridge" :border-width 2
:release-command
(default-release-toolbar chooser)))
(lb (listbox-of chooser)))
;; Associate new bindings to the listbox
(bind lb "<ButtonRelease-1>" (lambda (x y |X| |Y|)
(create-new-widget lb x y |X| |Y|)))
;; Change characteristics of root window
(set! (title *top-root*) (format #f "AMIB ~A" *amib-version*))
(set! (maximum-size *top-root*) '(1000 1000))
(set! (geometry *top-root*) "+10-10")
;; Pack everybody
(pack mess :fill "x" :ipadx 30 :ipady 5 :padx 5 :pady 5)
(pack bar :fill "x" :ipadx 30)
(pack chooser :expand #t :fill 'both :ipadx 5 :ipady 5 :padx 5 :pady 5)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Widget resize
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define *cursors* #("top_left_corner" "top_side" "top_right_corner"
"left_side" "crosshair" "right_side"
"bottom_left_corner" "bottom_side" "bottom_right_corner"))
(define *positions* #(NW N NE W center E SW S SE))
(define *grips-on* #f)
(define *resizing* #f)
(define *vector-of-grips* (make-vector 9 #f))
(define (widget-resize-start W X Y)
(let ((parent (parent W))
(width (winfo 'width W))
(height (winfo 'height W))
(bw (if (slot-exists? W 'border-width) (border-width W) 0)))
(if (equal? *grips-on* W)
(begin
(widget-resize-clear)
(set! *grips-on* #f))
(begin
(widget-resize-clear)
(set! *grips-on* W)
(dotimes (i 9)
(let ((butt (make <Frame> :parent parent :width 8 :height 8
:background "blue" :border-width 2 :relief "raised"
:cursor (vector-ref *cursors* i))))
(place butt :in W :bordermode "outside"
:anchor (vector-ref *positions* (- 8 i))
:relx (* 0.5 (modulo i 3))
:rely (* 0.5 (quotient i 3)))
;; Associate bindings to this grip
(bind butt "<ButtonPress-1>"
(lambda ()
(set! *resizing* #t)
(widget-resize-motion W (vector-ref *positions* i))
'break))
(bind butt "<ButtonRelease-1>"
(lambda ()
(set! *resizing* #f)
(widget-resize-release W)
'break))
;; Keep the grip in the global vector
(vector-set! *vector-of-grips* i butt)))
;; Place the central button on top (its index is 4)
(raise W)
(raise (vector-ref *vector-of-grips* 4))))))
(define (widget-resize-clear)
(for-each (lambda (x) (if (Tk-widget? x) (destroy x)))
(vector->list *vector-of-grips*)))
(define (widget-resize-motion W index)
(when *resizing*
(let* ((parent (parent W))
(pos-x (winfo 'rootx parent))
(pos-y (winfo 'rooty parent))
(width (winfo 'width W))
(height (winfo 'height W))
(x (winfo 'pointerx W))
(y (winfo 'pointery W))
(x1 (- (winfo 'rootx W) pos-x))
(y1 (- (winfo 'rooty W) pos-y))
(x2 (+ x1 width))
(y2 (+ y1 height))
(x (- X pos-x))
(y (- Y pos-y)))
(case index
((NW) (set! x1 x) (set! y1 y))
((N) (set! y1 y))
((NE) (set! x2 x) (set! y1 y))
((W) (set! x1 x))
((E) (set! x2 x))
((SW) (set! x1 x) (set! y2 y))
((S) (set! y2 y))
((SE) (set! x2 x) (set! y2 y))
((center) (set! x1 (- x (quotient width 2)))
(set! y1 (- y (quotient height 2)))
(set! x2 (+ x1 width))
(set! y2 (+ y1 height))))
(place 'forget W)
(place W :in parent :x x1 :y y1 :width (- x2 x1) :height (- y2 y1))
(after 30 (lambda () (widget-resize-motion W index))))))
(define (widget-resize-release W)
;; Calculate the relative width and height of the widget
(let* ((parent (parent W))
(pw (winfo 'width parent))
(ph (winfo 'height parent))
(pos-x (winfo 'rootx parent))
(pos-y (winfo 'rooty parent))
(width (winfo 'width W))
(height (winfo 'height W))
(x (- (winfo 'rootx W) pos-x))
(y (- (winfo 'rooty W) pos-y)))
(place 'forget W)
(place W :in parent
:relx (if (= pw 0) 0 (/ x pw))
:rely (if (= ph 0) 0 (/ y ph))
:relwidth (if (= pw 0) 0 (/ width pw))
:relheight (if (= ph 0) 0 (/ height ph)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Widget Geometry management
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (MAKE-PACKING-WINDOW W)
(define old-packing-options (if (equal? (winfo 'manager W) "pack")
(pack 'info W)
'()))
(define (build-var-name x)
(string->symbol (format #f "amib-~A~A" x (widget-name (Id W)))))
(define (make-var v val)
(let ((var (build-var-name v)))
(eval `(define ,var ',val) (global-environment))
var))
(define (change-pack-opt)
(pack 'forget W)
(pack W :side (eval (build-var-name 'side))
:anchor (eval (build-var-name 'anchor))
:fill (eval (build-var-name 'fill))
:expand (eval (build-var-name 'expand))
:padx (eval (build-var-name 'padx))
:pady (eval (build-var-name 'pady))
:ipadx (eval (build-var-name 'ipadx))
:ipady (eval (build-var-name 'ipady))))
(define (make-side parent)
(let* ((f (make <Frame> :parent parent :relief "groove" :border-width 2))
(val (get-keyword :side old-packing-options "top"))
(v (make-var 'side val)))
(pack (make <Label> :text "Side: " :parent f :font '(Courier -12))
:side "left")
(for-each (lambda (x)
(pack (make <Radio-button> :parent f :text x :variable v
:value x :command change-pack-opt)
:side "left" :expand #t :fill "x"))
'("top" "bottom" "left" "right"))
f))
(define (make-anchor parent)
(let* ((f (make <Frame> :parent parent :relief "groove" :border-width 2))
(val (string->symbol (get-keyword :anchor old-packing-options "center")))
(v (make-var 'anchor val)))
(dotimes (i 3)
(let ((g (make <Frame> :parent f)))
(dotimes (j 3)
(let ((anchor (vector-ref *positions* (+ (* i 3) j))))
(pack (make <Radio-Button> :text anchor :width 10 :parent g
:variable v :value anchor :anchor "w"
:command change-pack-opt)
:side "left" :expand #t :fill "x")))
(pack g :side "top")))
f))
(define (make-fill parent)
(let* ((f (make <Frame> :parent parent :relief "groove" :border-width 2))
(val (get-keyword :fill old-packing-options "none"))
(v (make-var 'fill val)))
(pack (make <Label> :text "Fill: " :parent f :font '(Courier -12))
:side "left")
(for-each (lambda (x)
(pack (make <Radio-button> :parent f :text x :variable v
:value x :command change-pack-opt)
:side "left" :expand #t :fill "x"))
'("none" "x" "y" "both"))
f))
(define (make-expand parent)
(let ((val (get-keyword :expand old-packing-options #f)))
(make <Check-button> :parent parent :relief "groove" :border-width 2
:text "Expand" :variable (make-var 'expand val) :value val
:command change-pack-opt)))
(define (make-padding parent)
(let ((f (make <Frame> :parent parent :relief "groove" :border-width 2)))
(for-each (lambda (x)
(let* ((val (get-keyword (make-keyword x) old-packing-options 10))
(v (make-var x val)))
(pack (make <Scale> :orientation "h" :parent f :text x
:variable v :value val
:command (lambda (_) (change-pack-opt)))
:expand #t :fill "x")))
'(ipadx ipady padx pady))
f))
;; MAKE-PACKING-WINDOW starts here
(let ((top (make <Toplevel> :title "Packer options" :class "Amib"
:geometry "-100+100")))
(pack (make-side top)
(make-anchor top)
(make-fill top)
(make-expand top)
(make-padding top)
:padx 5 :pady 5 :fill "x")
(pack (make <Button> :parent top :text "Dismiss" :command (lambda ()
(destroy top)))
:fill "x")))
(define (use-pack-for-widget W)
(place 'forget W)
(pack W :in (parent W))
(update)
(make-packing-window W))
(define (use-place-for-widget W)
(pack 'forget W)
(place W :in (parent W))
(update))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; edit-widget -- Interactively change widget options
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (edit-widget w)
(letrec ((top (make <Toplevel> :class "Amib" :title "Widget Editor"
:geometry "-10+10"))
(slots (map (lambda (x) (symbol->string (if (pair? x) (car x) x)))
(class-slots (class-of w))))
(filter (lambda (slots forget)
(let loop ((l slots) (res '()))
(cond
((null? l) res)
((member (car l) forget)
(loop (cdr l) res))
(else (loop (cdr l) (cons (car l) res)))))))
(maxl 0))
;; Display only useful slots
(set! slots (sort (filter slots *special-slots*) string<?))
(set! maxl (apply max (map string-length slots)))
;; Pretty name of this object
(let ((name-editor (make <Labeled-Entry>
:parent top
:title "Widget name"
:value (hash-table-get *pretty-names* w "?none?"))))
(bind (entry-of name-editor) "<Return>"
(lambda ()
(hash-table-put! *pretty-names* w (value name-editor))))
(pack name-editor :expand #t :fill 'x))
;; Display the geometry manager used for this widget
(let* ((f (make <Frame> :border-width 2 :relief "ridge" :parent top))
(v (string->symbol (format #f "cb-var~A" (widget-name (Id w)))))
(c1 (make <Radio-Button> :text "Packed" :variable v :parent f
:value "pack"
:command (lambda () (Use-pack-for-widget w))))
(c2 (make <Radio-Button> :text "Placed" :variable v :parent f
:value "place"
:command (lambda () (Use-place-for-widget w)))))
;; Set the valid check button
(eval `(set! ,v ,(if (null? (place 'info w)) "pack" "place")))
(pack c1 c2 :side "left" :expand #t :fill "x")
(pack f :expand #t :fill "x"))
;; Display the widget editor
(for-each (lambda (s)
(let* ((name (string->symbol s))
(le (make <Labeled-Entry> :parent top :title name
:width 40
:value (slot-ref w (string->symbol s)))))
;; Customize label
(set! (width (label-of le)) maxl)
(set! (anchor (label-of le)) "e")
;; Customize entry
(bind (entry-of le) "<Return>" (lambda ()
(slot-set! w name (value le))))
;; Pack the new entry
(pack le :fill "y" :expand #t)))
slots)
;; Dismiss button
(pack (make <Button> :text "Dismiss" :parent top
:command (lambda () (destroy top)))
:expand #t
:fill 'x)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Code generation
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (Pretty-name w)
(let ((name (hash-table-get *pretty-names* w #f)))
(unless name
;; If this object has no name, a name is generated for it
(set! name (if (eqv? w *top-root*) "*top-root*" (gensym "W")))
(hash-table-put! *pretty-names* w name))
name))
;;;;
;;;; Generate-placement: generate pack or place depending of the geometry manager
;;;; used.
;;;;
(define-method generate-placement ((w <Tk-widget>))
(let* ((infos (place 'info w))
(use-pack? (null? infos)))
(if use-pack?
(set! infos (pack 'info w)))
(format #t "(~A ~A " (if use-pack? "pack " "place") (pretty-name w))
;; Display informations returned by Tk
(let loop ((i infos))
(cond
((null? i) (display ")\n\n"))
((eqv? (car i) ':in) (format #t "\n :in ~A"
(pretty-name
(Id->instance (eval (cadr i)))))
(loop (cddr i)))
(ELSE (let ((val (cadr i)))
(format #t "\n ~S " (car i))
(if (number? val)
(display val)
(format #t "\"~A\"" val)))
(loop (cddr i)))))))
(define-method generate-placement ((w <Toplevel>))
#f)
;;;;
;;;; Generate-code-for-widget methods
;;;;
(define-method generate-code-for-widget ((w <Toplevel>))
(format #t "\n;; Definition of Toplevel ~A\n" (pretty-name w))
(next-method))
(define-method generate-code-for-widget ((w <Tk-widget>))
;; Generate name
(format #t ";-----------\n(define ~A (make ~A\n\t:parent ~A\n"
(pretty-name w) (class-name (class-of w)) (pretty-name (parent w)))
;; Generate non special slots
(for-each (lambda (slot)
(unless (member slot *special-slots*)
(unless (member (symbol->string (car slot)) *special-slots*)
;; Generate code for this slot (which is for sure a list)
(let* ((slot-name (car slot))
(val (slot-ref w slot-name))
(init-key (get-keyword :init-keyword (cdr slot) #f)))
(when (and init-key (not (equal? (slot-ref w slot-name) "")))
(format #t "\t~S ~A~S\n"
init-key (if (list? val) "'" "") val))))))
(class-slots (class-of w)))
;; Close parenthesis
(format #t "))\n\n")
;; Generate code for embedded widgets. Don't do this if w is a composite
(unless (is-a? w <Tk-composite-widget>)
(for-each generate-code-for-widget
(map Id->instance (winfo 'children w))))
;; Generate placement for this widget
(generate-placement w))
;;;;
;;;; Generate-code (the entry point of code generation)
;;;;
(define (generate-code file)
(let ((all-tops (map Id->instance (winfo 'children *root*))))
(letrec ((dump(lambda (func)
(for-each (lambda (x)
(when (and (is-a? x <Toplevel>)
(not (equal?(slot-ref x 'class) "Amib")))
(func x)))
all-tops))))
(with-output-to-file file
(lambda ()
(format #t ";;\n;; Code generated by Amib (v~A)\n;;\n" *amib-version*)
(format #t "(require \"Tk-classes\")")
(dump generate-code-for-widget)
(dump generate-placement))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; File Management
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (save-file)
(if *current-file*
(generate-code *current-file*)
(write-file)))
(define (load-file)
(let ((f (Tk:get-open-file)))
(when f (load f))))
(define (write-file)
(let ((f (Tk:get-save-file)))
(when f
(set! *current-file* f)
(generate-code f))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Inits
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(bind "all" "<ButtonRelease-1>" (lambda () (set! *resizing* #f)))
(new-amib-toplevel)
(build-interface)
Reference in New Issue View Git Blame Copy Permalink