home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Pocket Forth 0.6.3 / Examples / Reader < prev    next >
Encoding:
Text File  |  1993-06-29  |  20.2 KB  |  287 lines  |  [TEXT/McSk]
  1. rect  ( old brect )
  2. 2variable B1PICT  ( hold b1's pict handle )
  3. 2variable B2PICT  ( hold b2's pict handle )
  4. 2variable B3PICT  ( hold b3's pict handle )
  5.  
  6. ( draw the three bird positions )
  7. : .B1  red 2 0 !pen 6 0 -to 12 6 -to 18 0 -to 22 0 -to  black ;
  8. : .B2  red 0 6 !pen 24 6 -to black ;
  9. : .B3  red 2 12 !pen 6 12 -to 12 6 -to 18 12 -to 22 12 -to black ;
  10.  
  11. : +BIRD \ initialize the birds pictures & store the handles
  12.     brect picture .b1 pclose b1pict 2!
  13.     brect picture .b2 pclose b2pict 2!
  14.     brect picture .b3 pclose b3pict 2!
  15.     0 0 0 0 brect !rect  0 0 0 0 obrect !rect ;
  16. : -BIRD  b1pict pkill b2pict pkill b2pict pkill ;
  17.  
  18. : B1 brect b1pict 2@ pdraw ;
  19. : B2 brect b2pict 2@ pdraw ;
  20. : B3 brect b3pict 2@ pdraw ;
  21. create .BS  ' b1 ,  ' b2 ,  ' b3 ,  ( bird draw array )
  22. variable BTHIS  0 bthis !  ( offset to the current routine )
  23. 4 constant #BIRDS  \ (number_of_birds-1)*2
  24.  
  25. : THISBIRD ( -- n ) bthis @ ;  \   the current bird
  26. : NEXTBIRD ( -- ) 2 bthis +! ;  \  set bthis to the next bird
  27. : FIRSTBIRD ( -- ) 0 bthis ! ;   \ first picture in sequence
  28. : .BIRD ( n -- ) .bs + @  execute ;  \ draw bird n
  29.  
  30. : MOVEBIRD 3 -1 brect roffset ;  \  translate brect down1 for 3right
  31. : SHRINKBIRD 1 1 brect rinset ;   \ shrink brect by 2 pixels
  32.  
  33. : ANIMATE ( -- ) ( draw the flying red bird )
  34.     brect ?empty IF                   \ if bird has shrunk to oblivion...
  35.       48 291 60 309 brect !rect  THEN  \ ...restore its origonal size
  36.     obrect rerase                  \   erase the old rect
  37.     brect @rect obrect !rect        \  set old rect to current rect
  38.     0 -1 obrect rinset               \ expand old rect for full erasure
  39.     thisBird .bird                    \ draw the bird
  40.     thisBird #birds < IF            \    if its bird 1 or 2
  41.       nextBird  moveBird             \   increment bird and move rect
  42.     ELSE                              \  its bird 3
  43.       firstBird moveBird shrinkBird    \ cycle, move & shrink
  44.     THEN ;
  45.  
  46.  
  47. ( rects for pictures )
  48. rect PRECT   15  48 212 405 prect !rect  ( title picture rect )
  49. rect SRECT  192 222 221 370 srect !rect  ( signature rect )
  50. rect IRECT  170 194 203 227 irect !rect  ( icon rect )
  51.  
  52. : SCR ( -- ) @pen swap drop 16 + 50 swap !pen ;  ( special cr )
  53. : BCR ( -- ) @pen swap drop 50 swap !pen ;  ( cr without lf )
  54.  
  55. ( P1 - P? are page drawing routines.  They have no stack effect.)
  56. : P1  cls  prect 4000 dpict .farrow ;
  57.  
  58. : P2  cls scr
  59.     ."       Its FAST, its FUN and its FREE!" scr scr
  60.     ."    Its Pocket Forth, a programming language for" scr
  61.     ."  writing Macintosh applications and DAs." cr scr
  62.     ."    You can take advantage of many new features" scr
  63.     ."  in this release such as Apple Events*, Floating" scr
  64.     ."  Point, Gestalt** and Drag & Drop* programming." cr scr
  65.     ."    Learn Forth programming with the contents of" scr
  66.     ."  the Starting folder (inside the Extensions folder.)"
  67.     scr scr scr ."            * System 7   ** System 6.0.4+"
  68.     srect 4001 dpict  ( draw signature picture )
  69.     .arrows ;
  70.  
  71. : P3  cls scr
  72.     ."   Code produced by Pocket Forth is compact and fast." cr scr
  73.     ."   Pocket Forth produces true machine code, so" scr
  74.     ." you have complete control over your program." cr scr
  75.     ."   Examine and run the example and extension" scr
  76.     ." files for programming suggestions." cr scr
  77.     ."    If you have system 7 you can load text files by" scr
  78.     ."  dragging a text file icon onto Pocket Forth's icon." cr scr
  79.     ."  All systems can use the menu to “Open” a file."
  80.     143 392 176 425 irect !rect  ( set icon rect )
  81.     128 irect .icon  ( draw the icon )
  82.     .arrows ;
  83.  
  84. : P4  cls scr
  85.     ."   Print and read the Manual and the Glossary." cr scr
  86.     ."   The Manual consists of two TeachText documents" scr
  87.     ." suitable for use as a reference to Pocket Forth." cr scr
  88.     ."   The Glossary, also a TeachText document, is a" scr
  89.     ." list of the words in the Pocket Forth dictionary." scr
  90.     ." Stack effects, pronunciation and usage are shown." cr scr
  91.     ."   An addendum describes the desk accessory." cr scr
  92.     ."   Other document files abound." scr
  93.     .arrows ;
  94.  
  95. : P5  cls scr
  96.     ." Major changes since release 5:" scr scr
  97.     ."  • Floating point numbers!" cr scr
  98.     ."    Numeric input containing a decimal point is" scr
  99.     ."    interpreted as an extended floating point" scr
  100.     ."    number. Floating Point numbers are kept on" scr
  101.     ."    the stack as ten byte entities."  cr scr
  102.     ."    SANE is used along with three dozen new" scr
  103.     ."    words that manipulate floating point numbers." cr scr scr
  104.     ."                                ( continued ... )"
  105.     .arrows ;
  106.  
  107. : P6  cls scr
  108.     ." Floating point continued ..." cr scr
  109.     ."    Stack words:      "  2 !face
  110.                            ." fdrop   fdup   fswap   fpick" scr
  111.     ."                               fpack   froll   f>d   d>f" cr scr
  112.     0 !face ."    Memory words: " 2 !face ." f@   f!   fliteral   f," scr
  113.     ."                               fconstant   fvariable" cr scr
  114.     0 !face ."    I/O words:         " 2 !face
  115.                                     ." fnumber   sci   fix   f." cr scr
  116.     0 !face ."    Math words:      " 2 !face
  117.                                     ." fcompare   f+   f-   f*   f/" scr
  118.     ."                               frem   f^   fint   fabs   fsqrt" scr
  119.     ."                               fsin   fcos   ftan   fatn" scr
  120.     ."                               fexp   fln"  0 !face
  121.     .arrows ;
  122.  
  123.  
  124. : P7  cls scr
  125.     ."  • Apple Events:" cr scr
  126.     21 352 54 385 irect !rect  ( set icon rect )
  127.     128 irect .icon  ( draw the icon )
  128.     ."    Apple Events (System 7 required) are the" scr
  129.     ."    standard conduit for inter-application" scr
  130.     ."    communication. Pocket Forth programs may" scr
  131.     ."    define new Apple event handlers. The four" scr
  132.     ."    required events and all user defined events" scr
  133.     ."    are installed automatically when Pocket" scr
  134.     ."    Forth starts." cr scr
  135.     ."    Examples for HyperCard and Frontier are" scr
  136.     ."    in the 'Extensions:Apple Events' folder." cr scr
  137.     ."                                ( continued ... )"
  138.     .arrows ;
  139.  
  140.  
  141. : P8  cls scr
  142.     ." New words and variables control Apple Events:" cr scr
  143.     2 !face ."    AE:  " 0 !face ." and " 2 !face ." AE:  " 0 !face
  144.     ."    begin and end event definitions" scr
  145.     2 !face ."    ,S  " 0 !face
  146.     ."            compile (or stack) 4 bytes from ASCII" cr scr
  147.     2 !face  ."    +Md  " 0 !face ." variables:" scr
  148.     ."            136    Apple Event handler routine" scr
  149.     ."            188    Address of installation list" scr
  150.     ."            190    Error handler routine ("
  151.                          2 !face ." drop "  0 !face ." )" scr
  152.     ."            198    Reply record handle holder" scr
  153.     ."            202    Apple Event record handle"
  154.     .arrows ;
  155.  
  156. : P9  cls scr
  157.     ."  • Use " 2 !face ." ?gestalt  " 0 !face
  158.        ." to query the system." cr scr
  159.     ."    Using this new system trap, available since" scr
  160.     ."    late system 6, you can determine much about" scr
  161.     ."    the system software and hardware."  scr scr
  162.     ."  • A color conscious window is created if a" scr
  163.     ."    color machine is in use. This has no visual" scr
  164.     ."    effect but allows your programs to use color." scr scr
  165.     ."  • A new color icon and signature is used."
  166.     336 216 !pen  lfont ." p4TH" sfont
  167.     175 335 207 367 irect !rect  ( set icon rect )
  168.     129 irect .icon  ( draw the icon )
  169.     .arrows ;
  170.  
  171. : P10  cls scr
  172.     ." New for 6.3:" cr scr
  173.     ."  • The word \ makes comments more effecitve." cr scr
  174.     ."  • " 2 !face ." Warm  " 0 !face
  175.         ." restarts Pocket Forth, but leaves" scr
  176.     ."    the dictionary intact." cr scr
  177.     ."  • " 2 !face ." Depth  " 0 !face
  178.         ." lets you know how many items are" scr
  179.     ."    on the stack." scr scr
  180.     ."  • Check out the Balloon Help."
  181.     .arrows ;
  182.  
  183. : P11  cls scr
  184.     ." Bug fixes:" cr scr
  185.     ."  • The manual has been updated and now" scr
  186.     ."    prints with pictures, without errors." cr scr
  187.     ."  • " 2 !face ." Back  " 0 !face
  188.        ." now compiles correct branches." cr scr
  189.     ."  • A 32 bit address error in the update" scr
  190.     ."    routine has been fix                          for Frontier and HyperCard." cr scr
  191.     ."                                    A library of utility routines." bcr
  192.     ."      Misc" cr scr
  193.     ."                                    The Forth Vendors Group" bcr
  194.     ."      fvgFloatingPoint" scr
  195.     ."                                    floating point standard."
  196.     128 94 161 127 irect !rect  ( set icon rect )
  197.     128 irect .icon  ( draw the icon )
  198.     .arrows ;
  199.  
  200. : P18  cls scr
  201.     ."     If you find a bug, need help, or want to talk" scr
  202.     ."    about this, write. I'd like to hear from you and" scr
  203.     ."    I'll attempt to answer your mail." cr scr
  204.     ."    Do not send any money, Pocket Forth is free!" cr scr
  205.     ."    Contact me at any of the following addresses:" scr
  206.     ."      CompuServe     [70566,1474]" scr
  207.     ."      AOL                   cheilman" scr
  208.     ."      Email                “heilman@pc.maricopa.edu”" scr
  209.     ."      U.S. Mail           PO box 8345" scr
  210.     ."                               Phoenix AZ 85066-8345"
  211.     .aarrow ;
  212.  
  213. \ page list
  214. variable PWHICH  0 pwhich !  ( page-1 to be drawn )
  215. 17 constant PNO  ( number of pages-1 )
  216. create PLIST  ( ordered list of routines or "pages" )
  217.     ' p1 ,  ' p2 ,  ' p3 ,  ' p4 ,
  218.     ' p5 ,  ' p6 ,  ' p7 ,  ' p8 ,
  219.     ' p9 ,  ' p10 , ' p11 ,  ' p12 ,
  220.     ' p13 ,  ' p14 ,  ' p15 ,  ' p16 ,
  221.     ' p17 ,  ' p18 ,
  222.  
  223. ( update, menu, button and idle handlers )
  224. : DOUP  pwhich @ 2* plist + @ execute ;  ( draw the pwhichth page )
  225. : DON ( n -- ) pwhich ! doup ;  ( go to nth page )
  226. : DOAFT  pwhich @ 1 - 0 max don ;  ( decrement pwhich )
  227. : DOFOR  pwhich @ 1+ pno min don ;  ( increment pwhich )
  228. : DOFIRST  0 don ;  ( go to first page )
  229. : DOLAST  pno don ;  ( go to last page )
  230. : DONEW 4 don ;  \ go to "whats new" page
  231. : DOBUG 10 don ;  \ go to "bug fixes" page
  232. : DONOTE 12 don ;  \ go to "notes" page
  233. : DOPACK 14 don ;   \ go to "packing list" page
  234.  
  235. : STOP  -bird bye ; ( stop animating )
  236.  
  237. \ menu list
  238. create GMENU ' dofirst , ' doaft , ' dofor , ' dolast ,
  239.    ' null ,  ' donew ,  ' dobug ,  ' donote ,  ' dopack ,  ' dolast ,
  240. create FMENU ' stop ,
  241. create MBAR fmenu ,  18 +md @ 2+ @ ,  gmenu ,
  242. 2variable GMENUH  0 0 gmenuh 2!  ( holder for goMenuHandle )
  243. ' beep  18 +md @  ( get pointer to menu list )
  244.         2+ @  ( get pointer to Edit menu from menu list )
  245.         8 + !  ( set paste handler to beep )
  246.  
  247. : +MENU ( -- ) ( Turn the new menu on.)
  248.     0 0 2>r 4 >r ,$ A9BF  ( _GetRMenu )
  249.     2r> 2dup 2>r 0 >r ,$ A935  ( _InsertMenu )
  250.     gmenuh 2!  ,$ A937 ;  ( _DrawMenuBar )
  251.  
  252. : DOBUTT  ( -- ) ( button handler )
  253.     @mouse apoly ?phit IF apoly 2@ 2>r ,$ A8C9 doaft ELSE
  254.       @mouse fpoly ?phit IF fpoly 2@ 2>r ,$ A8C9  dofor 
  255.     THEN  THEN ;
  256.  
  257. \ Idle procedure
  258. variable TLAST  0 tlast !  ( timer )
  259. 10 constant DELAY
  260. : TICKS ( -- n ) 364 0 l@ ;
  261. : ?TIME ( -- flags ) ( true if 1/delay seconds has elapsed )
  262.     ticks tlast @ - abs delay > ;
  263. : DOIDLE  ( do the first page animation )
  264.     pwhich @ 0= IF  ( if its the title page )
  265.       ?time IF ticks tlast !  animate
  266.     THEN  THEN ;
  267.  
  268. \ startup procedure
  269. : START  sfont   \ Set to 12 point Chicago
  270.     2 >r ,$ A889  \ SrcXor _TextMode
  271.     +apoly +fpoly       \    This is stuff that must
  272.     +menu  +bird         \   be set up at runtime,
  273.     128 +icon  129 +icon  \  because it uses handles.
  274.     BEGIN ?terminal drop AGAIN ;  ( event loop )
  275.  
  276. \ This is event handlers and data to set up when this is loaded.
  277. ' doup    14 +md !  \ set update handler
  278. ' dobutt  16 +md !  \ set button handler
  279.   mbar    18 +md !  \ set the menu handlers
  280. ' doidle  20 +md !  \ set idle handler
  281. ' stop    22 +md !  \ set quit handler
  282. ' start   26 +md !  \ set startup handler
  283. ' null   136 +md !  \ disable Apple Events
  284. 450 250   8 +md 2!  \ set window size
  285.  
  286. save  bye
  287.