home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / DESKTOP.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  3.5 KB  |  126 lines
  1. ;* DESKTOP.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.02 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Event-driven Object-Oriented desktop system        *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: L. Bartholdi & M. Vuilleumier        Date: Oct 1993    *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. (define desktop
  23.   (letrec
  24.     (
  25.       (running #F)
  26.       (time-unit 3)
  27.       (handlers '())
  28.       (delta 8)
  29.  
  30.       (register
  31.     (lambda (him)
  32.       (set! handlers (cons him handlers))
  33.     ))
  34.  
  35.       (handler
  36.     (let* ((state 'NONE)
  37.            (wait (lambda ()
  38.                (mouse 'ENABLE)
  39.                ((named-lambda (loop then)
  40.               (if (< (clock) then)
  41.                   (loop then)))
  42.             (+ (clock) time-unit))))
  43.            (count-left 0)
  44.            (count-center 0)
  45.            (count-right 0)
  46.            (update (lambda (events)
  47.              (if (memq 'LEFT-DOWN events)
  48.                  (set! count-left (1+ count-left)))
  49.              (if (memq 'CENTER-DOWN events)
  50.                  (set! count-center (1+ count-center)))
  51.              (if (memq 'RIGHT-DOWN events)
  52.                  (set! count-right (1+ count-right)))
  53.                ))
  54.            (dragger (lambda (events buttons x y . rest)
  55.               (cond ((null? buttons)    ; all released
  56.                  (set! state 'NONE)
  57.                  (mouse 'HANDLER `((BUTTONS) . ,handler))
  58.                  (mouse 'DISABLE)
  59.                  (for-each (lambda (him) (him 'DRAG-END x y))
  60.                        handlers)
  61.                  (mouse 'ENABLE))
  62.                 ((memq 'MOVE events)
  63.                  (for-each (lambda (him) (him 'DRAG-MOVE x y))
  64.                        handlers))
  65.               )))
  66.           )
  67.       (lambda (events buttons x y . rest)
  68.         (case state
  69.           (NONE (set! state 'WAITING)
  70.             (set! count-left 0)
  71.             (set! count-center 0)
  72.             (set! count-right 0)
  73.             (update events)
  74.             (wait)
  75.             (let ((inq (mouse 'INQ)))
  76.               (if (and (null? (car inq))
  77.                    (< (abs (- x (cadr inq))) delta)
  78.                    (< (abs (- y (caddr inq))) delta))
  79.               (begin
  80.                 (set! state 'NONE)
  81.                 (mouse 'DISABLE)
  82.                 (for-each (lambda (him)
  83.                     (him 'CLICK count-left count-center count-right x y))
  84.                       handlers)
  85.                 (mouse 'ENABLE))
  86.               (begin
  87.                 (set! state 'DRAG)
  88.                 (mouse 'HANDLER `((UP MOVE) . ,dragger))
  89.                 (mouse 'DISABLE)
  90.                 (for-each (lambda (him)
  91.                     (him 'DRAG-START (car inq) x y))
  92.                       handlers)
  93.                 (mouse 'ENABLE))
  94.               )))
  95.           (WAITING (update events)
  96.                (wait))
  97.         ))))
  98.  
  99.       (install
  100.     (lambda ()
  101.       (mouse 'RESET)
  102.       (mouse 'SHOW)
  103.       (set! running (mouse 'HANDLER `((BUTTONS) . ,handler)))))
  104.  
  105.       (uninstall
  106.     (lambda ()
  107.       (mouse 'HANDLER running)
  108.       (set! running #F)))
  109.  
  110.       (me
  111.     (lambda (message . args)
  112.       (apply (case message
  113.            (REGISTER    register)
  114.            (UNINSTALL   uninstall)
  115.            (TIME-UNIT   (lambda l (begin0 time-unit (if l (set! time-unit (car l))))))
  116.            (DELTA       (lambda l (begin0 delta (if l (set! delta (car l))))))
  117.            (else (%error-invalid-operand 'DESKTOP message)))
  118.          args)))
  119.     )
  120.  
  121.     (lambda args
  122.       (if (not running)
  123.       (install))
  124.       (if args (apply me args)))
  125.   ))
  126.