experiments/gui.ss
author Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
Thu, 31 Mar 2005 01:25:02 +1200
changeset 0 ea4e1a00864c
permissions -rw-r--r--
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
0
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     1
; GUI.SS  Graphical User Interface for LISP2
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     2
;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     3
; (C) 1995 Tony Garnock-Jones
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     4
; tonyg@kcbbs.gen.nz
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     5
;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     6
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     7
;----------------------------------------------------------------------------;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     8
; Graphics toolbox calls.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
     9
;----------------------------------------------------------------------------;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    10
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    11
(require 'form)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    12
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    13
(define (rectangle rule thickness x y w h)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    14
    (apply BitBlt screen-form '() '() rule
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    15
                  x y thickness h
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    16
                  (append clipping-rectangle '(0 0)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    17
    (apply BitBlt screen-form '() '() rule
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    18
                  x y w thickness
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    19
                  (append clipping-rectangle '(0 0)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    20
    (apply BitBlt screen-form '() '() rule
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    21
                  (+ x (- w thickness)) y thickness h
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    22
                  (append clipping-rectangle '(0 0)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    23
    (apply BitBlt screen-form '() '() rule
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    24
                  x (+ y (- h thickness)) w thickness
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    25
                  (append clipping-rectangle '(0 0))))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    26
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    27
(define (fill-rect shade rule x y w h)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    28
    (apply BitBlt screen-form '() shade rule
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    29
                  x y w h
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    30
                  (append clipping-rectangle '(0 0))))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    31
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    32
;----------------------------------------------------------------------------;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    33
; The window system proper.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    34
;----------------------------------------------------------------------------;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    35
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    36
;;; Class <rectangle>
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    37
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    38
;;; Represents a rectangle; used in screen geometry calculations.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    39
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    40
(define-class <rectangle> <object> (x y w h))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    41
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    42
;;; (<rectangle> new: x y w h)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    43
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    44
;;; Creates and returns a rectangle with the specified coordinates.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    45
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    46
(define-class-method <rectangle> (self new: x y w h)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    47
    (let ((n (self new)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    48
        (n set: <rectangle> x x)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    49
        (n set: <rectangle> y y)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    50
        (n set: <rectangle> w w)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    51
        (n set: <rectangle> h h)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    52
        n))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    53
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    54
;;; (rect x2)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    55
;;; (rect y2)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    56
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    57
;;; Return the coordinates of the right-hand lower corner of the rectangle.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    58
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    59
(define-method <rectangle> (self x2)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    60
    (+ (self : <rectangle> x) (self : <rectangle> w)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    61
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    62
(define-method <rectangle> (self y2)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    63
    (+ (self : <rectangle> y) (self : <rectangle> h)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    64
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    65
;;; (rect write-to: port)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    66
;;; (rect display-to: port)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    67
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    68
;;; Displays the textual representation of a rectangle to the given IO port.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    69
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    70
(let ((method
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    71
        (lambda (self port)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    72
            (display-to port "#<rectangle ")
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    73
            (display-to port (self : <rectangle> x)) (display-to port " ")
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    74
            (display-to port (self : <rectangle> y)) (display-to port " ")
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    75
            (display-to port (self : <rectangle> w)) (display-to port " ")
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    76
            (display-to port (self : <rectangle> h))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    77
            (display-to port ">"))))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    78
    (<rectangle> add-method: 'write-to: method)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    79
    (<rectangle> add-method: 'display-to: method))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    80
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    81
;;; (rect contains? x y)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    82
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    83
;;; Returns true if the rectangle contains the point (x, y); otherwise
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    84
;;; returns false.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    85
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    86
(define-method <rectangle> (self contains? x y)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    87
    (and (>= x (self : <rectangle> x))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    88
         (>= y (self : <rectangle> y))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    89
         (<= (- x (self : <rectangle> x)) (self : <rectangle> w))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    90
         (<= (- y (self : <rectangle> y)) (self : <rectangle> h))))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    91
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    92
;;; (min a b)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    93
;;; (max a b)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    94
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    95
;;; Return the minimum/maximum of the two arguments.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    96
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    97
(define (min a b)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    98
    (if (< a b) a b))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
    99
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   100
(define (max a b)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   101
    (if (> a b) a b))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   102
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   103
;;; (rect intersect: rect2)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   104
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   105
;;; Returns either a new rectangle, which is the area common to both arguments,
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   106
;;; or #f if there is no overlap.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   107
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   108
(define-method <rectangle> (self intersect: other)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   109
    (let ((result (<rectangle> new:
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   110
                    (max (self : <rectangle> x) (other : <rectangle> x))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   111
                    (max (self : <rectangle> y) (other : <rectangle> y))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   112
                    (min (self x2) (other x2))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   113
                    (min (self y2) (other y2)))))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   114
        (result set: <rectangle> w
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   115
            (- (result : <rectangle> w) (result : <rectangle> x)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   116
        (result set: <rectangle> h
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   117
            (- (result : <rectangle> h) (result : <rectangle> y)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   118
        (if (or (<= (result : <rectangle> w) 0)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   119
                (<= (result : <rectangle> h) 0))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   120
            #f
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   121
            result)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   122
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   123
;;; (rect not)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   124
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   125
;;; Returns a list of rectangles, which when taken together cover all of a
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   126
;;; 640x480 screen excluding the area covered by the argument.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   127
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   128
(define-method <rectangle> (self not)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   129
    (list
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   130
        (<rectangle> new: 0                       (self : <rectangle> y)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   131
                          (self : <rectangle> x)  (self : <rectangle> h))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   132
        (<rectangle> new: (self x2)               (self : <rectangle> y)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   133
                          (- 640 (self x2))       (self : <rectangle> h))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   134
        (<rectangle> new: 0                       0
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   135
                          640                     (self : <rectangle> y))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   136
        (<rectangle> new: 0                       (self y2)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   137
                          640                     (- 480 (self y2))      )))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   138
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   139
;;; (rect ->list)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   140
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   141
;;; Returns a list containing x, y, w and h.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   142
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   143
(define-method <rectangle> (self ->list)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   144
    (list
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   145
        (self : <rectangle> x)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   146
        (self : <rectangle> y)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   147
        (self : <rectangle> w)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   148
        (self : <rectangle> h)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   149
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   150
;;; (rect grow: xdelta ydelta)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   151
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   152
;;; Changes size of rect by adding/subtracting xdelta or ydelta to/from each
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   153
;;; coordinate.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   154
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   155
(define-method <rectangle> (self grow: x y)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   156
    (self set: <rectangle> x (- (self : <rectangle> x) x))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   157
    (self set: <rectangle> y (- (self : <rectangle> y) y))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   158
    (self set: <rectangle> w (+ (self : <rectangle> w) (* x 2)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   159
    (self set: <rectangle> h (+ (self : <rectangle> h) (* y 2))))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   160
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   161
;;; (rect move: xdelta ydelta)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   162
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   163
;;; Changes position of rect by adding xdelta or ydelta to each coordinate.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   164
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   165
(define-method <rectangle> (self move: x y)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   166
    (self set: <rectangle> x (+ (self : <rectangle> x) x))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   167
    (self set: <rectangle> y (+ (self : <rectangle> y) y)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   168
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   169
;;; (rect copy)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   170
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   171
;;; Returns a new <rectangle> identical to the argument.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   172
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   173
(define-method <rectangle> (self copy)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   174
    (apply ((self class) get-class-method: 'new:) (self class) (self ->list)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   175
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   176
;;; (rect top-left)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   177
;;; (rect bottom-right)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   178
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   179
;;; Return coordinates of the corner requested.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   180
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   181
(define-method <rectangle> (self top-left)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   182
    (list
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   183
        (self : <rectangle> x)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   184
        (self : <rectangle> y)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   185
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   186
(define-method <rectangle> (self bottom-right)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   187
    (list
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   188
        (self x2)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   189
        (self y2)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   190
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   191
;----------------------------------------------------------------------------;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   192
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   193
;;; Class <view>
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   194
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   195
;;; Abstract windowable (displayable) object.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   196
;;; Instance variables:
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   197
;;;     bounds      The rectangle representing the area of the screen covered
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   198
;;;                 by the view.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   199
;;;     owner       The view under which this view is logically grouped.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   200
;;;     children    Views logically grouped under this view.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   201
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   202
(define-class <view> <object> (bounds owner children))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   203
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   204
;;; (<view> new: x y w h owner)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   205
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   206
;;; Creates and returns a view with the given coordinates, and the given
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   207
;;; logical owning view.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   208
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   209
(define-class-method <view> (self new: x y w h owner)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   210
    (let ((n (self new)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   211
        (n set: <view> bounds (<rectangle> new: x y w h))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   212
        (n set: <view> children '())
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   213
        (unless (null? owner)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   214
            (owner add-child: n))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   215
        n))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   216
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   217
;;; (view destroy)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   218
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   219
;;; Cleans up as a view is removing itself from the windowing system.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   220
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   221
(define-method <view> (self destroy)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   222
    (unless (null? (self : <view> owner))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   223
        ((self : <view> owner) remove-child: self)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   224
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   225
;;; (view has-focus?)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   226
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   227
;;; Returns true if this view has the input focus.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   228
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   229
(define-method <view> (self has-focus?)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   230
    (eq? (desktop : <desktop> focus) self))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   231
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   232
;;; (view paint: rect)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   233
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   234
;;; Sets up the graphics system to draw stuff in the area specified by rect.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   235
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   236
(define-method <view> (self paint: area)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   237
    (set! clipping-rectangle (area ->list)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   238
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   239
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   240
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   241
;;; (view draw: rect)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   242
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   243
;;; Repaints the areas of view and its children which are contained within the
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   244
;;; region of the screen represented by rect.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   245
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   246
;;; WARNING: The primitive form of this method relies on the structure of the
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   247
;;; classes <view> and <rectangle>. Be careful when changing those classes to
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   248
;;; also update the information used by this method.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   249
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   250
(<view> add-method: 'draw: %%draw-method-for-<view>-objects)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   251
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   252
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   253
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   254
;;; (view add-child: child)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   255
;;; (view remove-child: child)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   256
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   257
;;; Add or remove child views from a view.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   258
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   259
(define-method <view> (self add-child: child)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   260
    (unless (member child (self : <view> children))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   261
        (child set: <view> owner self)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   262
        (self set: <view> children
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   263
            (cons child (self : <view> children)))))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   264
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   265
(define-method <view> (self remove-child: child)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   266
    (let ((l (member child (self : <view> children))))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   267
        (when l
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   268
            (child set: <view> owner '())
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   269
            (if (null? (cdr l))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   270
                (set-car! l #f)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   271
                (begin
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   272
                    (set-car! l (cadr l))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   273
                    (set-cdr! l (cddr l)))))))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   274
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   275
;----------------------------------------------------------------------------;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   276
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   277
;;; Class <desktop>
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   278
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   279
;;; The root view in the windowing system is an instance of class <desktop>.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   280
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   281
(define-class <desktop> <view> (focus))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   282
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   283
;;; (<desktop> new)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   284
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   285
;;; Creates a new desktop, setting its logical boundaries to the screen size.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   286
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   287
(define-class-method <desktop> (self new)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   288
    (let ((n (self as: <view> new)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   289
        (n set: <view> bounds
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   290
            (<rectangle> new: 0 0 640 480))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   291
        (n set: <desktop> focus '())
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   292
        n))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   293
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   294
;;; (desktop paint: area)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   295
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   296
;;; Redraws areas of the desktop.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   297
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   298
(define-method <desktop> (self paint: area)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   299
    (self as: <view> paint: area)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   300
    (apply fill-rect grey-25 3 ((self : <view> bounds) ->list)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   301
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   302
;;; (desktop draw)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   303
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   304
;;; Refresh the entire screen.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   305
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   306
(define-method <desktop> (self draw)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   307
    (self draw: (self : <view> bounds)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   308
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   309
;----------------------------------------------------------------------------;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   310
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   311
;;; Class <window>
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   312
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   313
;;; This is pretty self-evident :-)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   314
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   315
(define-class <window> <view> (title flags))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   316
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   317
;;; (<window> new: x y w h owner title)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   318
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   319
;;; Creates and returns a window with the specified attributes.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   320
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   321
(define-class-method <window> (self new: x y w h owner title)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   322
    (let ((n (self as: <view> new: x y w h owner)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   323
        (n set: <window> title title)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   324
        n))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   325
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   326
;;; (window paint: area)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   327
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   328
;;; Refresh areas of the window.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   329
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   330
(define-method <window> (self paint: area)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   331
    (self as: <view> paint: area)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   332
    (let ((bounds ((self : <view> bounds) copy)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   333
        (apply fill-rect '() 15 (bounds ->list))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   334
        (apply rectangle 0 2 (bounds ->list))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   335
        (bounds grow: -2 -2)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   336
        (bounds set: <rectangle> h (+ (gui-font : <font> height) 2))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   337
        (screen-form print-string:
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   338
            (self : <window> title)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   339
            (+ (bounds : <rectangle> x) 2)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   340
            (+ (bounds : <rectangle> y) 2)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   341
            gui-font 4)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   342
        (apply BitBlt screen-form '() '() 0
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   343
                      (bounds : <rectangle> x) (bounds y2)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   344
                      (bounds : <rectangle> w) 2
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   345
                      (append clipping-rectangle '(0 0)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   346
        (if (self has-focus?)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   347
            (apply BitBlt screen-form '() '() 10
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   348
                          (append (bounds ->list)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   349
                                  clipping-rectangle
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   350
                                  '(0 0)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   351
            (apply BitBlt screen-form '() grey-25 4
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   352
                          (append (bounds ->list)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   353
                                  clipping-rectangle
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   354
                                  '(0 0))))))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   355
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   356
;----------------------------------------------------------------------------;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   357
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   358
;;; desktop
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   359
;;;
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   360
;;; The system-wide desktop.
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   361
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   362
(define desktop (<desktop> new))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   363
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   364
(desktop add-child: (<window> new: 100 100 (- 200 100) (- 200 100) desktop "Title 2"))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   365
(desktop add-child: (<window> new: 370 300 (- 620 370) (- 460 300) desktop "Title 3"))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   366
(desktop add-child: (<window> new: 320 50 (- 420 320) (- 450 50) desktop "Title 4"))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   367
(desktop add-child: (<window> new: 120 160 (- 500 120) (- 400 160) desktop "Title 5"))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   368
(desktop add-child: (<window> new: 140 120 (- 400 140) (- 300 120) desktop "Title 9"))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   369
(desktop add-child: (<window> new: 50 140 (- 550 50) (- 350 140) desktop "Title 7"))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   370
(desktop add-child: (<window> new: 150 150 (- 250 150) (- 250 150) desktop "Title 14"))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   371
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   372
(define gui-font smalthin-font) ;modernb-font)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   373
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   374
(define (test-gui)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   375
    (graphics-mode)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   376
    (desktop draw)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   377
    (let ((background (<form> new: 8 16)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   378
        (let loop ((state (get-mouse)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   379
            (let ((x (list-ref state 0))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   380
                  (y (list-ref state 1))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   381
                  (b (list-ref state 2)))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   382
                (unless (= b 7)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   383
                    (if (= b 3)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   384
                        (desktop draw))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   385
                    (set! clipping-rectangle '(0 0 640 480))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   386
                    (BitBlt background screen-form '() 3
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   387
                            0 0 8 16
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   388
                            0 0 8 16
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   389
                            x y)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   390
                    (screen-form print-string: "" x y system-font 4)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   391
                    (BitBlt screen-form background '() 3
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   392
                            x y 8 16
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   393
                            0 0 640 480
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   394
                            0 0)
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   395
                    (loop (get-mouse))))))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   396
    (text-mode))
ea4e1a00864c Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff changeset
   397