You'll find enclosed a mini interface builder for STklos. It is written in
STklos and it was developped quickly in spare time. I thought that it was
possible to have a prototype of an interface builder in less than 300 lines...
I loosed since it is (exactly!) 400 lines long.
Remember it is a prototype and not a complete tool. In particular nothing is
done to change default bindings.
Enjoy
-- Erick
;;;;
;;;; a m i b . s t k -- A mini interface builder. I hope it will serve
;;;; as the basis of something more complete...
;;;;
;;;; Copyright (C) 1993, 1994 Erick Gallesio - I3S - CNRS / UNSA <eg_at_unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; Author: Erick Gallesio [eg_at_unice.fr]
;;;; Creation date: 19-Sep-1994 16:00
;;;; Last file update: 26-Sep-1994 10:33
(require "unix")
(require "Toplevel")
(require "Canvas")
(require "Frame")
(require "Button")
(require "Lentry")
(require "Menu")
(require "Scale")
(require "Filebox")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Some definitions.
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define *amib-version* 0.1)
(define *pretty-names* (make-hash-table))
(define *first* #f)
(define *current-file* #f)
(define *grid* 0)
(define *special-slots* '("id" "eid" "parent" "width" "height"))
(define *table-defaults* (list
(list <Button> "Button" '(:text "Button"))
(list <Check-button> "Check button" '(:text "Check" :anchor "w"))
(list <Radio-button> "Radio button" '(:text "Radio" :anchor "w"))
(list <Label> "Label" '(:text "Label"))
(list <Labeled-entry> "Labeled entry" '(:title "Title"))
(list <Scale> "Scale" '())))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; A new kind of toplevel (i.e. toplevel which contain a canvas for
;;;; designing widgets)
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class <AMIB-Toplevel> (<Toplevel>)
((canvas :getter canvas)
(all-toplevels :initform () :allocation :class)))
(define-method initialize ((self <AMIB-Toplevel>) initargs)
(next-method)
;; Push self in the list of already created toplevels
(slot-set! self 'all-toplevels (cons self (slot-ref self 'all-toplevels)))
;; Create the embodied canvas
(let ((c (make <Canvas> :parent self)))
(slot-set! self 'canvas c)
;; give default binding
(bind c "<1>" `(create-ghost ,(address-of self) %x %y))
(bind c "<B1-Motion>" `(move-ghost ,(address-of self) %x %y))
(bind c "<ButtonRelease-1>" `(delete-ghost ,(address-of self)))
;; pack the canvas
(pack c)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Utilities
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (toplevel-chidren top)
(map Id->instance (winfo 'children (canvas top))))
(define (round-to-grid n)
(if (= *grid* 0)
n
(* *grid* (round (/ n *grid*)))))
(define-macro (associated-window w)
`(car (find-items (parent ,w) 'withtag (Eid ,w))))
(define (change-width w to)
(set! (width (associated-window w)) (round-to-grid to)))
(define (change-height w to)
(set! (height (associated-window w)) (round-to-grid to)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; build-interface -- construct the button panel
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (build-interface)
(let* ((t (make <Toplevel>))
;; Title
(l (make <Label>
:parent t
:relief 'ridge
:border-width 3
:text (format #f "A Mini Interface Builder (V~A)"
*amib-version*)))
;; Menu bar
(bar (make <Frame> :parent t))
;; Widget Panel
(buttons (make <Frame> :parent t :relief 'groove :border-width 4)))
;; Menu bar
(let* ((file (make <Menu-Button> :parent bar :text " File "))
(window (make <Menu-button> :parent bar :text " Window "))
(grid (make <Menu-button> :parent bar :text " Grid "))
(menu1 (make <Menu> :parent file))
(menu2 (make <Menu> :parent window))
(menu3 (make <Menu> :parent grid)))
(menu-add menu1 'command :label "Load" :command '(load-file))
(menu-add menu1 'command :label "Save" :command '(save-file))
(menu-add menu1 'command :label "Save as" :command '(write-file))
(menu-add menu1 'separator)
(menu-add menu1 'command :label "Quit" :command '(exit))
(menu-add menu2 'command :label "Create" :command '(make <amib-toplevel>
))
(for-each (lambda (x)
(menu-add menu3 'radiobutton
:label x
:command `(set! *grid* ,x)
:variable '*grid*))
'(0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30))
(pack file window grid :side 'left))
;; Fill the "buttons" frame
(for-each (lambda (x)
(let ((type (class-name (car x)))
(name (cadr x))
(dflt (caddr x)))
(pack (make <Button>
:parent buttons
:text name
:command `(create-widget ',type ',dflt))
:side 'left
:padx 10
:pady 10)))
*table-defaults*)
;; Pack everybody
(pack l bar :expand #t :fill 'x)
(pack bar)
(pack buttons :expand #t :fill 'both)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; create-widget
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (create-widget type defaults)
(set! *destroy-ghost-hook* (cons type defaults)))
(define (make-widget parent type defaults)
(let* ((area (coords *ghost*))
(areaX1 (car area))
(areaY1 (cadr area))
(areaX2 (caddr area))
(areaY2 (cadddr area))
(x (/ (+ areaX1 areaX2) 2))
(y (/ (+ areaY1 areaY2) 2))
(height (abs (- areaY2 areaY1)))
(width (abs (- areaX2 areaX1)))
(W (apply make (eval type) :parent parent defaults)))
(place-widget W x y width height (gensym "widg"))))
(define (place-widget W x y width height name)
(let* ((tag (widget-name (Eid W)))
(Win (make <Window>
:parent (parent W)
:coords (list x y)
:height height
:width width
:tags tag
:window (Eid W))))
(hash-table-put! *pretty-names* W name)
;; Button 1 bindings (move)
(bind W "<1>" `(start-move ,(address-of W) ,tag |%X| |%Y|))
(bind W "<B1-Motion>" `(motion-move |%X| |%Y|))
(bind W "<ButtonRelease-1>" `(stop-move))
;; Button 2 (Delete widget)
(bind W "<2>" '(destroy (Id->instance |%W|)))
;; Button 3 (Configure widget)
(bind W "<3>" '(edit-widget (Id->instance |%W|)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Ghost management
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define *ghost* #f)
(define *destroy-ghost-hook* #f)
(define (create-ghost toplevel x y)
(let* ((canvas (canvas toplevel))
(x (canvas-x canvas x))
(y (canvas-y canvas y)))
(set! *ghost* (make <Rectangle> :parent canvas
:coords (list x y x y)))))
(define (move-ghost toplevel x y)
(let* ((canvas (canvas toplevel))
(x (round-to-grid (canvas-x canvas x)))
(y (round-to-grid (canvas-y canvas y)))
(old (coords *ghost*)))
(slot-set! *ghost* 'coords (list (car old) (cadr old) x y))))
(define (delete-ghost toplevel)
(when *destroy-ghost-hook*
(make-widget (parent *ghost*)
(car *destroy-ghost-hook*)
(cdr *destroy-ghost-hook*)))
;; And finally destroy ghost
(destroy *ghost*))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Move management
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define start-move #f)
(define motion-move #f)
(define stop-move #f)
(let ((last-x 0) (last-y 0) (current-canvas #f))
;; Start-move
(set! start-move (lambda (object tag x y)
(set! current-canvas (parent object))
(set! last-x x)
(set! last-y y)
(delete-tag current-canvas 'selection)
(add-tag current-canvas 'selection 'with tag)
(raise object)))
;; Motion-move
(set! motion-move (lambda (x y)
(move current-canvas 'selection (- x last-x) (- y last-y))
(set! last-x x)
(set! last-y y)))
;; Stop-move
(set! stop-move (lambda ()
(delete-tag current-canvas 'selection))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; edit-widget -- Interactively change widget options
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (edit-widget w)
(letrec ((top (make <Toplevel> :class "Widget Editor"))
(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>"
`(hash-table-put! *pretty-names* ,(address-of w)
(value ,(address-of name-editor))))
(pack name-editor :expand #t :fill 'x))
;; Set scale and height for w
(let ((s1 (make <Scale> :parent top :to 400 :orientation 'horizontal
:text "Width" :value (winfo 'width w)))
(s2 (make <Scale> :parent top :to 400 :orientation 'horizontal
:text "Height" :value (winfo 'height w))))
(set! (command s1) (format #f "change-width ~A" (address-of w)))
(set! (command s2) (format #f "change-height ~A" (address-of w)))
(pack s1 s2 :fill 'y :expand #t))
;; Display the widget editor
(for-each (lambda (s)
(let* ((name (string->symbol s))
(le (make <Labeled-Entry>
:parent top
:title name
:width 50
: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>"
`(slot-set! ,(address-of w)
',name (value ,(address-of le))))
;; Pack the new entry
(pack le :fill "y" :expand #t)))
slots)
;; Dismiss button
(pack (make <Button> :text "Dismiss" :parent top
:command `(destroy ,(address-of top)))
:expand #t
:fill 'x)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Code generation
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (generate-code file)
(with-output-to-file file
(lambda ()
(format #t ";;\n;; Code automatically generated by amib V~A\n;;\n"
*amib-version*)
(for-each (lambda (top)
(let ((top-name (gensym "Top")))
(format #t ";; Generating code for toplevel ~S\n\n" top)
(format #t "(define ~A (make <amib-toplevel>))\n\n" top-name)
(for-each (lambda (x)
(format #t ";; Generating code for widget ~S\n" x)
(code-for-widget x top-name))
(toplevel-chidren top))))
(slot-ref *first* 'all-toplevels)))))
(define (code-for-widget w parent-name)
(let ((w-name (hash-table-get *pretty-names* w))
(coords (coords (associated-window w))))
;; Generate name
(format #t "(define ~A (make ~A\n\t:parent (canvas ~A)\n"
w-name (class-name (class-of w)) parent-name)
;; Generate non special slots
(for-each (lambda (slot)
(when (equal? (get-slot-allocation slot) :tk-virtual)
(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) "??")))
(unless (equal? (slot-ref w slot-name) "")
(format #t "\t~S ~S\n" init-key val))))))
(class-slots (class-of w)))
;; Close parenthesis
(format #t "))\n\n")
(format #t ";; Place it\n\n")
(format #t "(place-widget ~A ~A ~A ~A ~A '~A)\n;;-------------\n"
w-name (car coords) (cadr coords) (winfo 'width w) (winfo 'height w)
w-name)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; File Management
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (save-file)
(if *current-file*
(generate-code *current-file*)
(write-file)))
(define (load-file)
(let ((f (make-file-box)))
(when f (load f))))
(define (write-file)
(let ((f (make-file-box)))
(when f
(set! *current-file* f)
(generate-code f))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Inits
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(wm 'withdraw *root*)
(build-interface)
(set! *first* (make <amib-toplevel>))
-- Erick
Received on Mon Sep 26 1994 - 10:39:08 CET