home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 September / Simtel20_Sept92.cdr / msdos / aijournl / aifirst.arc / CLI.SAI < prev    next >
Lisp/Scheme  |  1986-10-30  |  2KB  |  72 lines
  1.  
  2.  
  3. CLI LISP Drunken Sailor Problem
  4.  
  5.  
  6. ;
  7. ;; The Drunken Sailor Problem
  8. ;
  9. (defun drunken ()
  10.   (lo-res)
  11.   (set-pallette 1)
  12.   (setf x 160
  13.     y 100
  14.         *step* 5
  15.         *-step* (- *step*)
  16.         side 70
  17.         xbot (- x side)
  18.         xtop (+ x side)
  19.         ybot (- y side)
  20.         ytop (+ y side))
  21.   ; draw the starting location
  22.   (draw-box x y *step* *-step*)
  23.   ; draw the finish line
  24.   (draw-box x y side (- side))
  25.   ; set a large time slice because there will be alot of switching
  26.   (setf *time-slice* 300)
  27.   ; initiate concurrent execution
  28.   (cobegin '(walk x y 1) '(walk x y 2) '(walk x y 3))
  29.   (alpha)
  30. )
  31. (defun draw-box (x y d+ d-)
  32.   (%draw-line (+ x d-) (+ y d-) (+ x d+) (+ y d-) 1 0)
  33.   (%draw-line (+ x d+) (+ y d-) (+ x d+) (+ y d+) 1 0)
  34.   (%draw-line (+ x d+) (+ y d+) (+ x d-) (+ y d+) 1 0)
  35.   (%draw-line (+ x d-) (+ y d+) (+ x d-) (+ y d-) 1 0)
  36. )
  37. (defun walk (x y color)
  38.   (let ((x-old x)
  39.         (y-old y))
  40.   (do ((x-new (step x-old)
  41.               (step x-old))
  42.        (y-new (step y-old)
  43.               (step y-old)))
  44.       ((done-p x-old y-old))
  45.     ; use the gclisp drawing primitive
  46.     (%draw-line x-old y-old x-new y-new color 0)
  47.     (setf x-old x-new)
  48.     (setf y-old y-new)))
  49. )
  50. (defun step (old)
  51.   ; take random steps
  52.   (+ old (rand *-step* *step*))
  53. )
  54. (defun done-p (x y)
  55.   (or (< x xbot) (> x xtop)
  56.       (< y ybot) (> y ytop))
  57. )
  58. ; taken from the gclisp examples
  59. ; load the line drawing primitive
  60. (UNLESS (FBOUNDP '%DRAW-LINE)
  61.   (WITH-DISKETTE *EXAMPLE-DISKETTE* #'FASLOAD
  62.      (MERGE-PATHNAMES "DLINE.FAS" *EXAMPLE-PATHNAME*)))
  63. ; switch to lo-resolution graphics
  64. (DEFUN LO-RES () (%sysint #X10 4 0 0 0) t)
  65. ; return to alphanumeric
  66. (DEFUN ALPHA () (%sysint #X10 3 0 0 0) t)
  67. ; set the colors (1 or 2)
  68. (defun set-pallette (x)
  69.   (%sysint #x10 #x0b00 (logior #x100 (logand x 1)) 0 0)
  70. )
  71.  
  72.