home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga MA Magazine 1998 #6
/
amigamamagazinepolishissue1998.iso
/
coders
/
jËzyki_programowania
/
clisp
/
fd
/
window.lsp
< prev
Wrap
Lisp/Scheme
|
1977-12-31
|
6KB
|
173 lines
;;;; Open a little window and draw lines
(in-package "AFFI-DEMOS")
(use-package "AFFI")
(export 'make-window-demo)
(defun test-pointer (p &optional error)
(if (nzero-pointer-p p) p
(when error (error "Null pointer assertion failed!"))))
;;; declare used libraries
;; care is taken that the compiled file will not load any fd files
(eval-when (compile eval load)
(declare-library-base :SysBase "exec.library")
(declare-library-base :IntuitionBase "intuition.library"))
(eval-when (eval compile)
(require-library-functions "exec.library"
:import '("AllocMem" "FreeMem"))
(require-library-functions "intuition.library"
:import '("OpenWindowTagList" "CloseWindow"
"DrawBorder")))
(eval-when (compile eval load)
(declare-library-base :UtilityBase "utility.library"))
(eval-when (eval compile)
(require-library-functions "utility.library"
:import '("AllocateTagItems" "FreeTagItems")))
;;; taglist management
;; I wrote no parser for C include files so I have to define
;; everything myself.
(defconstant MEMF_ANY 1)
(defconstant MEMF_CLEAR (ash 1 16))
(defconstant TAG_DONE 0)
(defconstant TAG_USER (ash 1 31))
(defconstant WA_Dummy (+ TAG_USER 99))
(defconstant WA_Left (+ WA_Dummy #x1))
(defconstant WA_Width (+ WA_Dummy #x3))
(defconstant WA_Height (+ WA_Dummy #x4))
(defconstant WA_IDCMP (+ WA_Dummy #x7))
(defconstant WA_DragBar (+ WA_Dummy #x1f))
(defconstant WA_DepthGadget (+ WA_Dummy #x20))
(defconstant WA_CloseGadget (+ WA_Dummy #x21))
;; caller must unwind-protect
;; taglist is simple because it cannot accept Lisp strings (for WA_Title)
(defun make-simple-taglist (&rest args)
;; always terminate taglist with TAG_DONE
(let ((length (length args)))
(unless (evenp length)
(error "TagList of uneven length: ~S" args))
(with-open-library ("utility.library")
(let ((mem (mlibcall AllocateTagItems (1+ (/ length 2)))))
;; mem-write does test-pointer
(do ((i 0 (1+ i))
(args args (rest args)))
((null args)
(mem-write mem 4 TAG_DONE (* 4 i)))
(mem-write mem (if (typep (first args) '(unsigned-byte 32)) 4 -4)
(first args) (* 4 i)))
mem))))
;;; open window
(defun make-window-taglist (taglist)
(with-open-library ("utility.library")
(with-open-library ("intuition.library")
(let ((win-tags (apply #'make-simple-taglist taglist)))
(test-pointer win-tags :error)
(unwind-protect
(mlibcall OpenWindowTagList 0 win-tags)
(mlibcall FreeTagItems win-tags)))
)))
#|
(defmacro with-simple-taglist ((var . args) &body body)
`(let ((,var (make-simple-taglist ,@args)))
(unless (nzero-pointer-p ,var)
(error "Couldn't allocate Taglist"))
(unwind-protect (progn ,@body)
(mlibcall FreeTagItems ,var))))
|#
;; unwind-protect is very useful for all software development
(defun make-window-demo
(&key width (height 150)
(taglist
(list* WA_Left 20
WA_Height height
;;WA_CloseGadget 1
WA_DragBar 1
WA_DepthGadget 1
WA_IDCMP 0
(if width (list WA_Width width)))))
(with-open-library ("intuition.library")
(let (win)
(unwind-protect
(progn
(setq win (make-window-taglist taglist))
;; avoid ~X as window may be FOREIGN-POINTER in future
(let ((*print-base* 16)) (format t "~&Window ~S~%" win))
(window-fun1 win))
(when (test-pointer win nil) (mlibcall CloseWindow win))))))
;;; memory primitives
(defmacro with-mem ((var size flags) &body body)
(let ((sym (gensym)))
`(LET* ((,sym ,size)
(,var (MLIBCALL AllocMem ,sym ,flags)))
(WHEN (NZERO-POINTER-P ,var)
(UNWIND-PROTECT (PROGN ,@body)
(MLIBCALL FreeMem ,var ,sym))))))
;;; draw lines
;; Instead of all these mem-read/write with offset and type, it would
;; be better to define a simple equivalent of ffi:def-c-struct
;; (with-struct (LeftBorder) 'Window &body)
(defun draw-one-rectangle (window border x y width height)
(let (;;(rastport (mem-read window '* 50))
(xy (mem-read border '* 8)))
(mem-write xy -2 x 0)
(mem-write xy -2 y 2)
(mem-write xy -2 (+ x width) 4)
(mem-write xy -2 y 6)
(mem-write xy -2 (+ x width) 8)
(mem-write xy -2 (+ y height) 10)
(mem-write xy -2 x 12)
(mem-write xy -2 (+ y height) 14)
(mem-write xy -2 x 16)
(mem-write xy -2 y 18)
(mlibcall DrawBorder (mem-read window '* 50) border 0 0)))
(defun draw-rectangles (window border x y width height)
(do ((x x (+ x 2))
(y y (+ y 2))
(width width (- width 4))
(height height (- height 4)))
((or (>= 0 width) (>= 0 height)))
(draw-one-rectangle window border x y width height)))
(defconstant JAM1 0)
(defun window-fun1 (window)
(with-open-library ("exec.library")
(with-mem (border 16 (logior MEMF_ANY MEMF_CLEAR))
(with-mem (xy (* 2 2 5) MEMF_ANY)
(mem-write border '-2 (mem-read window -1 54) 0) ;LeftEdge:=BorderLeft
(mem-write border '-2 (mem-read window -1 55) 2) ;TopEdge :=BorderTop
(mem-write border '1 1 4) ;FrontPen, possibly use window->RPort->FgPen
(mem-write border '1 2 5) ;BackPen
(mem-write border '1 JAM1 6) ;DrawMode
(mem-write border '-1 5 7) ;Count
(mem-write border '* xy 8)
(mem-write border '* 0 12)
(draw-rectangles
window border
0 0
(- (mem-read window -2 8) (mem-read window -1 56) (mem-read window -1 54) 1) ;Width-BorderRight-BorderLeft-1
(- (mem-read window -2 10) (mem-read window -1 57) (mem-read window -1 55) 1)) ;Height-BorderBottom-BorderTop-1
(break "Have fun with window ~S" window)
(let ((sec 2))
(format t "~&Waiting ~R second~P.~%" sec sec)
(sleep sec))))))