home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / pcscheme.exe / SAMPLES / EYES.S < prev    next >
Encoding:
Text File  |  1993-10-04  |  4.2 KB  |  143 lines
  1. ;* EYES.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 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. ;*            A Simple Mouse Demo                *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: L. Bartholdi        Date: 19930930            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. ; 0 . . . . . . . . . . . . . . . . 
  23. ; 1 . . . . . . . . . . . . . . . . 
  24. ; 2 . . o o o . . . . . . . . . . . 
  25. ; 3 . o . . . o . . . . . . . . . . 
  26. ; 4 . o . . . o . . . . . . . . . . 
  27. ; 5 o . . . . . o . . . . . . . . . 
  28. ; 6 o . . . . . o . . . . . . . . . 
  29. ; 7 o . . . . . o . . . . . . . . . 
  30. ; 8 o . . . . . o . . . . . . . . . 
  31. ; 9 o . o o o . o . . . . . . . . . 
  32. ;10 o o . . . o o . . . . . . . . . 
  33. ;11 . o . . . o . . . . . . . . . . 
  34. ;12 . o . . . o . . . . . . . . . . 
  35. ;13 . . o o o . . . . . . . . . . . 
  36. ;14 . . . . . . . . . . . . . . . . 
  37. ;15 . . . . . . . . . . . . . . . . 
  38. ;  151413121110 9 8 7 6 5 4 3 2 1 0
  39.  
  40. (define open-eye '(0 0 ( #b0000000011111111
  41.              #b0000000011110111
  42.              #b0000000011100011
  43.              #b0000000011000001
  44.              #b0000000011000001
  45.              #b0000000010000000
  46.              #b0000000010000000
  47.              #b0000000010000000
  48.              #b0000000010000000
  49.              #b0000000010000000
  50.              #b0000000010000000
  51.              #b0000000011000001
  52.              #b0000000011000001
  53.              #b0000000011100011
  54.              #b0000000011110111
  55.              #b0000000011111111 )
  56.  
  57.                ( #b0000000000000000
  58.              #b0000000000000000
  59.              #b0000000000011100
  60.              #b0000000000100010
  61.              #b0000000000100010
  62.              #b0000000001000001
  63.              #b0000000001000001
  64.              #b0000000001000001
  65.              #b0000000001000001
  66.              #b0000000001011101
  67.              #b0000000001100011
  68.              #b0000000000100010
  69.              #b0000000000100010
  70.              #b0000000000011100
  71.              #b0000000000000000
  72.              #b0000000000000000 )
  73.                ))
  74. (define closed-eye `(0 0 ,(caddr open-eye)
  75.                  ( #b0000000000000000
  76.                #b0000000000000000
  77.                #b0000000000011100
  78.                #b0000000000100010
  79.                #b0000000000100010
  80.                #b0000000001000001
  81.                #b0000000001000001
  82.                #b0000000001011101
  83.                #b0000000001111111
  84.                #b0000000001110111
  85.                #b0000000001100011
  86.                #b0000000000110110
  87.                #b0000000000111110
  88.                #b0000000000011100
  89.                #b0000000000000000
  90.                #b0000000000000000 )
  91.                ))
  92.  
  93. (define (right pattern)
  94.   (map (lambda (x) (* x #x100)) pattern))
  95.  
  96. (define (join p1 p2)
  97.   (map (lambda (x y) (bitwise-or x y))
  98.        p1 (right p2)))
  99.  
  100. (define m0 (list 0 0
  101.          (join (caddr open-eye) (caddr open-eye))
  102.          (join (cadddr open-eye) (cadddr open-eye))))
  103. (define m1 (list 0 0
  104.          (join (caddr open-eye) (caddr closed-eye))
  105.          (join (cadddr open-eye) (cadddr closed-eye))))
  106. (define m2 (list 0 0
  107.          (join (caddr closed-eye) (caddr open-eye))
  108.          (join (cadddr closed-eye) (cadddr open-eye))))
  109. (define m3 (list 0 0
  110.          (join (caddr closed-eye) (caddr closed-eye))
  111.          (join (cadddr closed-eye) (cadddr closed-eye))))
  112.  
  113. (init-graph)
  114. (mouse 'RESET)
  115. (mouse 'SHOW)
  116. (mouse 'SHAPE m0)
  117. (mouse 'HANDLER `((LEFT RIGHT) . 
  118.           ,(lambda (event state . rest)
  119.              (mouse 'SHAPE
  120.                 (cond
  121.                   ((equal? state '()) m0)
  122.                   ((equal? state '(LEFT)) m1)
  123.                   ((equal? state '(RIGHT)) m2)
  124.                   ((equal? state '(LEFT RIGHT)) m3))))))
  125. (writeln "Press any key to abort...")
  126. ((rec loop
  127.    (lambda (count)
  128.      (when (not (char-ready?))
  129.        (let ((fade (* 100 (exp (/ (* count count) -40000.0)))))
  130.      (if (> (random 100) fade)
  131.          (begin
  132.            (mouse 'HIDE)
  133.            (mouse 'SHOW)
  134.            (set-color 0))
  135.          (set-color (1+ (random (-1+ (get-max-color)))))))
  136.        (line (cons (random (car (get-max-xy))) (random (cdr (get-max-xy))))
  137.          (cons (random (car (get-max-xy))) (random (cdr (get-max-xy)))))
  138.        (loop (1+ count)))))
  139.  0)
  140. (read-char)
  141. (close-graph)
  142. (mouse 'RESET)
  143.