home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 2: PC / frozenfish_august_1995.bin / bbs / d01xx / d0181.lha / AMXLISP / lsp / demo.lsp < prev    next >
Lisp/Scheme  |  1989-02-25  |  2KB  |  64 lines
  1. ; Basic Demo
  2.  
  3. (load "allocate")
  4. (load-c-struct "intuition/intuition" '(newwindow window intuitext))
  5. (load-c-struct "graphics/rastport" '(rastport))
  6. (load-c-struct "exec/ports" '(msgport))
  7. (defamiga 'Wait 'exec)
  8. (defamiga 'OpenWindow 'intuition)
  9. (defamiga 'CloseWindow 'intuition)
  10. (defamiga 'SetWindowTitles 'intuition)
  11. (defamiga 'PrintIText 'intuition)
  12. (defvar wtitle "AMXLisp Demo")
  13. (defvar itxt "Hello Word")
  14.  
  15.  
  16. ; beuark !
  17. (defmacro str-address (str)
  18.    `(memory-long (+ (address-of ,str) 6)))
  19.  
  20. ; !!??????!!!!
  21. (defmacro iexp (x y)
  22.    `(truncate (expt (float ,x) (float ,y))))
  23. ; 2^31 ???
  24. (defun power2 (x)
  25.    (cond ((equal x 31) 2147483648)
  26.          (t (iexp 2 x))))
  27.  
  28. (defun demo ()
  29.    (let ((nw (newamiga newwindow))
  30.          (txt (newamiga intuitext)))
  31.        (send nw :-> 'LeftEdge 10)
  32.        (send nw :-> 'TopEdge 10)
  33.        (send nw :-> 'Width 400)
  34.        (send nw :-> 'Height 100)
  35.        (send nw :-> 'DetailPen 0)
  36.        (send nw :-> 'BlockPen 1)
  37.        (send nw :-> 'IDCMPFlags #x200)  ; CLOSEWINDOW
  38.        (send nw :-> 'Flags #x100f)      ; ACTIVATE | all system gadgets
  39.        (send nw :-> 'MinWidth 40)
  40.        (send nw :-> 'MinHeight 40)
  41.        (send nw :-> 'Type 1)
  42.        (send txt :-> 'FrontPen 2)
  43.        (send txt :-> 'BackPen 3)
  44.        (send txt :-> 'LeftEdge 20)
  45.        (send txt :-> 'TopEdge  20)
  46.        (send txt :-> 'FrontPen 2)
  47.        (send txt :-> 'IText (str-address itxt))
  48.  
  49.        (let ((myw (send window :new (callamiga 'OpenWindow intuition nw))))
  50.             (callamiga 'SetWindowTitles intuition myw wtitle 0)
  51.             (callamiga 'PrintIText intuition (send myw :-> 'RPort) txt 0 0)
  52.             (dotimes (i 1000) ())
  53.             (callamiga 'Wait exec (power2
  54.                                         (send (send myw :-> 'UserPort)
  55.                                               :-> 'mp_SigBit)))
  56.             (callamiga 'CloseWindow intuition myw)
  57.             (freeamiga nw) (freeamiga txt))))
  58.  
  59.  
  60.  
  61.  
  62.  
  63.  
  64.