(let ()
(define-class (point x y) (<base>) (ivars (x x) (y y)) (inherited) (inheritable)
(private
(delta-x (pt) (abs (- x (send pt get-x))))
(delta-y (pt) (abs (- y (send pt get-y)))))
(protected
(combine-deltas (x y) (error 'point "not sure how to combine deltas")))
(public (distance (pt) (combine-deltas (delta-x pt) (delta-y pt))) (get-x () x)
(get-y () y) (set-x! (val) (set! x val)) (set-y! (val) (set! y val))))
(*comment* " Note that the syntax for classes is currently very rigid:"
" no part of the class definition is optional. If this becomes"
" tedious it is straightforward to define macros that expand into"
" the full class definition." ""
" The first subform of the \\scheme{define-class} expression"
" gives the name of the class and a list of formal"
" parameters for which arguments must be supplied when an"
" instance of the class is constructed."
" These formals are visible in the expressions that initialize"
" the instance variables and the arguments to the" " base class."
" The second subform of the \\scheme{define-class} expression"
" names the base class and supplies the actual values"
" needed to initialize the base class. In the example"
" above, the base class is \\scheme{<base>} which takes no arguments." ""
" \\scheme{ivars} introduces a binding list of expressions"
" much like \\scheme{let}."
" The class formals are visible within these expressions."
" \\scheme{inherited} introduces a list of identifiers naming"
" instance variables inherited from the base class. These"
" variables are initialized by a super class."
" \\scheme{inheritable} introduces a list of identifiers naming"
" instance variables that may be inherited by subclasses derived"
" from this class. This list may include identifiers bound in"
" the \\scheme{ivars} or listed among the \\scheme{inherited}." " "
" Methods are divided into three groups: \\scheme{private} methods visible"
" only within a class, \\scheme{protected} methods visible within a class"
" and its subclasses,"
" and \\scheme{public} methods visible outside the class as well."
" Syntactically, a method is a list consisting of the method name,"
" the method formals (in any form accepted by \\scheme{lambda}), and"
" a sequence of expressions forming the method body."
" The instance variables and inherited instance variables"
" are visible within each method body, as are the other"
" methods and an implicit binding of \\scheme{self} to the instance."
" Calls to private and protected methods have the same syntax"
" as ordinary function calls. Public methods"
" are called using the \\scheme{send} macro:" ""
" \\scheme{(send instance message arg ...)}" ""
" \\noindent where \message is the name of a public method in the class"
" of which \instance is an instance. The \\scheme{define-generic}"
" macro takes the name of a public method and binds it to a macro"
" that expands into the appropriate use of \\scheme{send}." " Thus, given" ""
" \\scheme{(define-generic message)}" ""
" \\noindent the schema for calling public methods above becomes" ""
" \\scheme{(message instance arg ...)}" ""
" When a subclass extends a public method it is often convenient to"
" call the base method. This is possible using the \\scheme{send-base}"
" macro, which has syntax identical to \\scheme{send}, but which calls"
" the specified method in the base class." ""
" In the \\scheme{point} example above, \\scheme{delta-x} and \\scheme{delta-y} are private"
" methods that compute the absolute difference in the \\scheme{x} and"
" \\scheme{y} values for two points. \\scheme{combine-deltas} is a protected"
" method that is redefined in the \\scheme{cartesian-point} and"
" \\scheme{manhattan-point} subclasses. \\scheme{point} provides public methods"
" for setting and accessing the instance variables, and a \\scheme{distance}"
" method that relies on a suitable implementation of \\scheme{combine-deltas}."
" Note that we must define \\scheme{combine-deltas} as a protected method"
" in \\scheme{point} so that the \\scheme{distance} method recognizes it as a protected"
" method."
" This is necessary because the \\scheme{distance} method is compiled without"
" knowlege of its subclasses, and has the added benefit that we get"
" a better error message if a subclass fails to define \\scheme{combine-deltas}"
" as a protected method." " When we redefine \\scheme{combine-deltas}"
" in the \\scheme{cartesian-point} and \\scheme{manhattan-point} classes below,"
" the inherited" " \\scheme{distance} method works as intended." ""
" Now we define a \\scheme{cartesian-point} class that"
" redefines the protected method \\scheme{combine-deltas}"
" so that the inherited \\scheme{distance} method computes the"
" cartesian distance between two points."
" Note that the base class \\scheme{point} is initialized with the"
" \\scheme{x} and \\scheme{y} values supplied to \\scheme{cartesian-point}.")
(define-class (cartesian-point x y) (point x y) (ivars) (inherited)
(inheritable) (private)
(protected (combine-deltas (dx dy) (sqrt (+ (* dx dx) (* dy dy))))) (public))
(*comment* " \\noindent For example")
(let ([a (make cartesian-point 1 1)] [b (make cartesian-point 4 5)])
(send a distance b))
(*comment* " \\noindent evaluates to \\scheme{5}." ""
" Next we define a \\scheme{manhattan-point} class that"
" redefines the protected method \\scheme{combine-deltas}"
" so that the inherited \\scheme{distance} method computes the"
" manhattan distance between two points."
" Note that the base class \\scheme{point} is initialized with the"
" \\scheme{x} and \\scheme{y} values supplied to \\scheme{manhattan-point}.")
(let ()
(define-class (manhattan-point x y) (point x y) (ivars) (inherited)
(inheritable) (private)
(protected (combine-deltas (delta-x delta-y) (+ delta-x delta-y))) (public))
(*comment* " \\noindent For example")
(let ([a (make manhattan-point 1 1)] [b (make manhattan-point 4 5)])
(send a distance b))))
(create <toplevel> with (title: "Toplevel Example") (height: (in->pixels 2))
(width: (in->pixels 3)))
When creating any widget (other than a <toplevel>), the widget's parent is passed as a positional argument to the create macro before the keyword arguments. Below we first create an appropriately titled toplevel window top to display the label. Next we create the label, passing top as a positional argument before the keyword arguments title: and font: which specify the string to be displayed and the font to display it in. We request a 14 point bold italic Times font. For labels and many other widgets that display text, the width/char: keyword is used to specify the width of the widget in characters. If width: is omitted, the label shrinks to fit its text. Here we specify a width of 30 characters to show that a label centers its text by default. The placement of the text can be adjusted with the anchor: and justify: keywords. Finally, to make the label visible we call the show method. The toplevel is visible by default.
(let ([top (create <toplevel> with (title: "Label Example"))])
(let ([label (create <label> top with (title: "This is a label")
(font: (create <font> 'times 14 '(bold italic))) (width/char: 30))])
(show label)))
When creating any widget (other than a <toplevel>), the widget's parent is passed as a positional argument to the create macro before the keyword arguments. Here we create a button with top as its parent. Initially the button displays "Never been clicked". The action: keyword introduces a procedure of one argument (the instance) to be called whenever the button is clicked. In this example, the callback procedure changes the title of the button, using set-title!, each time the button is clicked. We could also have written (set-option! button (title: ...)). Note that the width of the button is adjusted to fit its title whenever the title changes because we have not specified a value for the width: keyword. To make the button visible we call the show method.
(let ([top (create <toplevel> with (title: "Button Example"))])
(let ([button (create <button> top with (title: "Never been clicked")
(action:
(let ([count 0])
(lambda (self)
(set! count (+ count 1))
(set-title! self (format "~a click(s)" count))))))])
(show button)))
The <example-canvas> class below extends the mouse-press, mouse-release, and mouse-motion methods of the <canvas> class. The mouse-press method notifies a widget of the x- and y-coordinates and the state of the modifier keys when a mouse button is pressed while the mouse is over the widget. Using event-case, we inspect the set of modifiers to see whether the left mouse button is pressed. If so, we record the starting positions, update the help text displayed in the <label>, and create a new rectangle on the canvas at the place where the mouse was clicked. Otherwise we send the mouse-press notification on to the base class using the send-base syntax.
The mouse-motion method notifies a widget of the x- and y-coordinates and the state of the modifier keys when the mouse moves over the widget. If the left button is pressed, we update the coordinates of the rectangle to reflect the current position of the mouse.
The mouse-release method notifies a widget of the x- and y-coordinates and the state of the modifier keys when a mouse button is released while the mouse is over the widget. If the left button was released, we reset the state of the widget and reset the help text.
Although the example below does not demonstrate this, individual figures on the canvas can have event methods of their own. For instance, it is relatively easy to make the rectangles draggable with mouse button 2, or to make them resizable after they have been drawn.
(let* ([top (create <toplevel> with (title: "Canvas Example"))]
[start-text "Click button 1 in canvas below"]
[label (create <label> top with (title: start-text))])
(define-swl-class (<example-canvas> parent) (<canvas> parent)
(ivars (x1 #f) (y1 #f) (rect #f)) (inherited) (inheritable) (private)
(protected)
(public
(mouse-press
(x y mods)
(event-case
((modifier= mods))
(((left-button))
(set! x1 x)
(set! y1 y)
(set-title! label "Hold down button 1 and drag")
(set! rect (create <rectangle> self x1 y1 x1 y1)))
(else (send-base self mouse-press x y mods))))
(mouse-motion
(x y mods)
(event-case
((modifier= mods))
(((left-button))
(when rect
(set-coords! rect (min x x1) (min y y1) (max x x1) (max y y1))))
(else (send-base self mouse-motion x y mods))))
(mouse-release
(x y mods)
(event-case
((modifier= mods))
(((left-button)) (set! rect #f) (set-title! label start-text))
(else (send-base self mouse-release x y mods))))))
(let ([canvas (create
<example-canvas>
top
with
(background-color: (make <rgb> 215 215 255)))])
(show label)
(show canvas)))
We create a toplevel window top, an entry 20 characters wide called entry, and a horizontal scrollbar called scroll. We arrange for the entry to have the focus when top has focus via set-focus. Next we set entry's hscroll-notify: procedure to a procedure that informs the scrollbar scroll of the new left and right extents of the entry. This lets the scrollbar represent the position and size of the current view in the entry relative to the entry's total content. We set the action for the scrollbar to be a procedure that passes its number and qualifier arguments to the hscroll method of the entry. This tells the scrollbar who to notify and how to notify them when the user manipulates the slider vi keyboard or mouse.
Next we create a button titled "done" that retrieves via get-string the contents of the entry, prints the resulting string, then destroys the application by destroying the toplevel window top. The button and scrollbar are packed so that they expand and fill the horizontal dimension of their parent top. The entry is packed without these properties to illustrate the difference when the toplevel is resized. Run the demo, type a long string in entry, and try scrolling the contents.
(let* ([top (create <toplevel> with (title: "Entry Example"))]
[entry (create <entry> top with (width/char: 20))]
[scroll (create <scrollbar> top with (orientation: 'horizontal))])
(set-focus entry)
(set-option!
entry
(hscroll-notify: (lambda (left right) (set-view! scroll left right))))
(set-option! scroll (action: (lambda (self n q) (hscroll entry n q))))
(pack
(create <button> top with (title: "done")
(action:
(lambda (self) (printf "Entry: ~s~n" (get-string entry)) (destroy top))))
(expand: #t)
(fill: 'x))
(pack entry)
(pack scroll (expand: #t) (fill: 'x)))
In the following example we create a toplevel window containing a listbox. We use the make-menu macro to construct a menu with two top level entries, "_File" and "_Edit". The subforms make-menu are lists associating a string label with a procedure or a submenu. For example, the "_Open" label is associated with a procedure, returned by say, that inserts a string in the listbox lb, and the "_Disable" item is associated with a submenu constructed using make-menu. The underscore characters (`_') in the menu titles may be used to post a menu by pressing Alt and the letter following the underscore in the title of that menu. For example, pressing Alt+f posts the "File" menu.
Note how the entire "Edit" menu is enabled and disabled using set-enabled!. Individual menu items are enabled and disabled similarly. Below we use the find procedure to retrieve these items, but they could also be bound explicitly if the menu were constructed by hand.
The menu is installed on the <toplevel> window using the set-menu! method, and then the listbox lb is made visible under the frame via show.
(let* ([top (create <toplevel> with (title: "Menu Example"))]
[lb (create <listbox> top)]
[say (lambda (what) (lambda (self) (insert lb 0 what)))]
[find (let ()
(define massoc
(lambda (title menu)
(let loop ([ls (send menu get-menu-items)])
(cond
[(null? ls) #f]
[(string=? title (get-title (car ls))) (car ls)]
[else (loop (cdr ls))]))))
(define find
(lambda (full-path)
(let search ([path full-path] [found (send top get-menu)])
(if (not found)
(error 'find "bad menu path ~s" full-path)
(if (null? path)
found
(search (cdr path) (massoc (car path) found)))))))
find)]
[menu (make-menu
("_File"
(make-menu ("_Open" (say "Open")) ("_Save" (say "Save"))
("_Disable"
(make-menu
("Edit" (lambda (self) (set-enabled! (find '("_Edit")) #f)))
("Edit:Undo"
(lambda (self) (set-enabled! (find '("_Edit" "_Undo")) #f)))
("Edit:Zap"
(lambda (self)
(set-enabled! (find '("_Edit" "_Zap")) #f)))))
("_Enable"
(make-menu
("Edit" (lambda (self) (set-enabled! (find '("_Edit")) #t)))
("Edit:Undo"
(lambda (self) (set-enabled! (find '("_Edit" "_Undo")) #t)))
("Edit:Zap"
(lambda (self)
(set-enabled! (find '("_Edit" "_Zap")) #t)))))
("_Print"
(make-menu
("Draft" (say "Print Draft"))
("2-up" (say "Print 2-up"))))))
("_Edit"
(make-menu
("_Undo" (say "Undo"))
("_Process"
(make-menu
("_Fold" (say "Fold"))
("_Spindle" (say "Spindle"))
("_Mutilate" (say "Mutilate"))))
("_Zap"
(make-menu
("Blaster"
(make-menu
("Death _Ray" (say "Death Ray Blaster"))
("Ion _Pulse" (say "Ion Pulse Blaster"))))
("Phaser"
(make-menu
("_Stun" (say "Phaser = Stun"))
("_Maim" (say "Phaser = Maim"))
("_Frappe" (say "Phaser = Frappe")))))))))])
(set-menu! top menu)
(show lb))
The "Open" item on the "File" menu uses swl:file-dialog to present the user with a choice of filenames via the file selection dialog of the native window system. The 'open flag requires that the user specify an existing file. The optional file-types: parameter restricts the display to files with an extension matching "*.ss". If the user does not cancel out of the dialog, a string corresponding to the chosen filename is returned. In this case we update the title of the <toplevel> window accordingly, delete all text from the <text> widget, insert the contents of the file, and record the name of the selected file so that the file can be loaded when the "Run" menu item is selected.
(let ()
(define read-file
(lambda (filename txt)
(let ([buf (make-string 2048)])
(let loop ([ip (open-input-file filename)])
(let ([x (block-read ip buf 2048)])
(unless (eof-object? x)
(insert txt (if (< x 2048) (substring buf 0 x) buf))
(loop ip)))))))
(let* ([top (create <toplevel> with (title: "Tutorials"))]
[sf (create <scrollframe> top)]
[txt (create <text> sf)]
[tutorial #f])
(send txt set-font! (create <font> 'courier 12 '()))
(set-menu!
top
(make-menu
("_File"
(make-menu
("_Open"
(lambda (item)
(let ([filename (swl:file-dialog
"Select a tutorial"
'open
(file-types: '(("Scheme source" ("*.ss"))))
(parent: top))])
(when filename
(set-title! top (format "Tutorial: ~s" filename))
(delete-all txt)
(set! tutorial filename)
(read-file filename txt)))))
("_Run" (lambda (item) (when tutorial (load tutorial))))
("_Quit" (lambda (item) (destroy top)))))))
(pack sf (expand: #t) (fill: 'both))))
Below we create an appropriately titled toplevel window top to display a label. We create a <photo>, specifying the name of the file that contains the data. Currently supported file types are GIF and PPM. Next we create the label, with top as its parent, and specify the <photo> as the value for the keyword argument title:. Finally, to make the label visible we call the show method. The toplevel is visible by default.
The <bitmap> class is used just as the <photo> class, except that the specified file must contain monochrome X11 bitmap data.
(let ([top (create <toplevel> with (title: "Label Image Example"))]
[earth (create <photo> with (filename: "earth.gif"))])
(let ([label (create <label> top with (title: earth))]) (show label)))