home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-l.lha / fd / window.lsp < prev   
Encoding:
Lisp/Scheme  |  1996-08-13  |  5.8 KB  |  173 lines
  1. ;;;; Open a little window and draw lines
  2. (in-package "AFFI-DEMOS")
  3.  
  4. (use-package "AFFI")
  5.  
  6. (export 'make-window-demo)
  7.  
  8. (defun test-pointer (p &optional error)
  9.   (if (nzero-pointer-p p) p
  10.       (when error (error "Null pointer assertion failed!"))))
  11.  
  12. ;;; declare used libraries
  13. ;; care is taken that the compiled file will not load any fd files
  14.  
  15. (eval-when (compile eval load)
  16.   (declare-library-base :SysBase "exec.library")
  17.   (declare-library-base :IntuitionBase "intuition.library"))
  18. (eval-when (eval compile)
  19.   (require-library-functions "exec.library"
  20.     :import '("AllocMem" "FreeMem"))
  21.   (require-library-functions "intuition.library"
  22.     :import '("OpenWindowTagList" "CloseWindow"
  23.               "DrawBorder")))
  24.  
  25. (eval-when (compile eval load)
  26.   (declare-library-base :UtilityBase "utility.library"))
  27. (eval-when (eval compile)
  28.   (require-library-functions "utility.library"
  29.     :import '("AllocateTagItems" "FreeTagItems")))
  30.  
  31.  
  32. ;;; taglist management
  33. ;; I wrote no parser for C include files so I have to define
  34. ;; everything myself.
  35.  
  36. (defconstant MEMF_ANY 1)
  37. (defconstant MEMF_CLEAR (ash 1 16))
  38. (defconstant TAG_DONE 0)
  39. (defconstant TAG_USER (ash 1 31))
  40. (defconstant WA_Dummy   (+ TAG_USER 99))
  41. (defconstant WA_Left    (+ WA_Dummy #x1))
  42. (defconstant WA_Width   (+ WA_Dummy #x3))
  43. (defconstant WA_Height  (+ WA_Dummy #x4))
  44. (defconstant WA_IDCMP   (+ WA_Dummy #x7))
  45. (defconstant WA_DragBar (+ WA_Dummy #x1f))
  46. (defconstant WA_DepthGadget (+ WA_Dummy #x20))
  47. (defconstant WA_CloseGadget (+ WA_Dummy #x21))
  48.  
  49. ;; caller must unwind-protect
  50. ;; taglist is simple because it cannot accept Lisp strings (for WA_Title)
  51. (defun make-simple-taglist (&rest args)
  52.   ;; always terminate taglist with TAG_DONE
  53.   (let ((length (length args)))
  54.     (unless (evenp length)
  55.       (error "TagList of uneven length: ~S" args))
  56.     (with-open-library ("utility.library")
  57.       (let ((mem (mlibcall AllocateTagItems (1+ (/ length 2)))))
  58.         ;; mem-write does test-pointer
  59.         (do ((i 0 (1+ i))
  60.              (args args (rest args)))
  61.             ((null args)
  62.              (mem-write mem 4 TAG_DONE (* 4 i)))
  63.           (mem-write mem (if (typep (first args) '(unsigned-byte 32)) 4 -4)
  64.                      (first args) (* 4 i)))
  65.         mem))))
  66.  
  67. ;;; open window
  68.  
  69. (defun make-window-taglist (taglist)
  70.   (with-open-library ("utility.library")
  71.   (with-open-library ("intuition.library")
  72.     (let ((win-tags (apply #'make-simple-taglist taglist)))
  73.       (test-pointer win-tags :error)
  74.       (unwind-protect
  75.            (mlibcall OpenWindowTagList 0 win-tags)
  76.         (mlibcall FreeTagItems win-tags)))
  77.   )))
  78.  
  79. #|
  80. (defmacro with-simple-taglist ((var . args) &body body)
  81.   `(let ((,var (make-simple-taglist ,@args)))
  82.      (unless (nzero-pointer-p ,var)
  83.        (error "Couldn't allocate Taglist"))
  84.      (unwind-protect (progn ,@body)
  85.        (mlibcall FreeTagItems ,var))))
  86. |#
  87.  
  88. ;; unwind-protect is very useful for all software development
  89. (defun make-window-demo
  90.     (&key width (height 150)
  91.           (taglist
  92.            (list* WA_Left 20
  93.                   WA_Height height
  94.                   ;;WA_CloseGadget 1
  95.                   WA_DragBar 1
  96.           WA_DepthGadget 1
  97.                   WA_IDCMP 0
  98.                   (if width (list WA_Width width)))))
  99.   (with-open-library ("intuition.library")
  100.     (let (win)
  101.       (unwind-protect
  102.            (progn
  103.              (setq win (make-window-taglist taglist))
  104.              ;; avoid ~X as window may be FOREIGN-POINTER in future
  105.              (let ((*print-base* 16)) (format t "~&Window ~S~%" win))
  106.              (window-fun1 win))
  107.         (when (test-pointer win nil) (mlibcall CloseWindow win))))))
  108.  
  109. ;;; memory primitives
  110.  
  111. (defmacro with-mem ((var size flags) &body body)
  112.   (let ((sym (gensym)))
  113.     `(LET* ((,sym ,size)
  114.             (,var (MLIBCALL AllocMem ,sym ,flags)))
  115.        (WHEN (NZERO-POINTER-P ,var)
  116.          (UNWIND-PROTECT (PROGN ,@body)
  117.            (MLIBCALL FreeMem ,var ,sym))))))
  118.  
  119.  
  120. ;;; draw lines
  121.  
  122. ;; Instead of all these mem-read/write with offset and type, it would
  123. ;; be better to define a simple equivalent of ffi:def-c-struct
  124. ;; (with-struct (LeftBorder) 'Window &body)
  125.  
  126. (defun draw-one-rectangle (window border x y width height)
  127.   (let (;;(rastport (mem-read window '* 50))
  128.         (xy (mem-read border '* 8)))
  129.     (mem-write xy -2 x 0)
  130.     (mem-write xy -2 y 2)
  131.     (mem-write xy -2 (+ x width) 4)
  132.     (mem-write xy -2 y 6)
  133.     (mem-write xy -2 (+ x width) 8)
  134.     (mem-write xy -2 (+ y height) 10)
  135.     (mem-write xy -2 x 12)
  136.     (mem-write xy -2 (+ y height) 14)
  137.     (mem-write xy -2 x 16)
  138.     (mem-write xy -2 y 18)
  139.     (mlibcall DrawBorder (mem-read window '* 50) border 0 0)))
  140.  
  141. (defun draw-rectangles (window border x y width height)
  142.   (do ((x x (+ x 2))
  143.        (y y (+ y 2))
  144.        (width width (- width 4))
  145.        (height height (- height 4)))
  146.       ((or (>= 0 width) (>= 0 height)))
  147.     (draw-one-rectangle window border x y width height)))
  148.  
  149. (defconstant JAM1 0)
  150.  
  151. (defun window-fun1 (window)
  152.   (with-open-library ("exec.library")
  153.     (with-mem (border 16 (logior MEMF_ANY MEMF_CLEAR))
  154.       (with-mem (xy (* 2 2 5) MEMF_ANY)
  155.         (mem-write border '-2 (mem-read window -1 54) 0) ;LeftEdge:=BorderLeft
  156.         (mem-write border '-2 (mem-read window -1 55) 2) ;TopEdge :=BorderTop
  157.         (mem-write border '1 1 4)       ;FrontPen, possibly use window->RPort->FgPen
  158.         (mem-write border '1 2 5)       ;BackPen
  159.         (mem-write border '1 JAM1 6)    ;DrawMode
  160.         (mem-write border '-1 5 7)      ;Count
  161.         (mem-write border '* xy 8)
  162.         (mem-write border '* 0 12)
  163.         (draw-rectangles
  164.          window border
  165.          0 0
  166.          (- (mem-read window -2  8) (mem-read window -1 56) (mem-read window -1 54) 1) ;Width-BorderRight-BorderLeft-1
  167.          (- (mem-read window -2 10) (mem-read window -1 57) (mem-read window -1 55) 1)) ;Height-BorderBottom-BorderTop-1
  168.     (break "Have fun with window ~S" window)
  169.         (let ((sec 2))
  170.           (format t "~&Waiting ~R second~P.~%" sec sec)
  171.           (sleep sec))))))
  172.  
  173.