home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 079.lha / orbits.4th < prev    next >
Encoding:
FORTH Source  |  1986-11-20  |  7.4 KB  |  239 lines
  1. \ -----------------------------------------------
  2. \ ORBITS.4TH
  3. \ Robert L. Pyron, 7-Oct-87
  4. \ 53 Ashford St. #3
  5. \ Allston, MA 02142
  6. \
  7. \ Written in Multi-Forth, version 1.21
  8. \
  9. \ Copyright (C) 1987 by Robert L. Pyron
  10. \ This program may be freely distributed for
  11. \ non-commercial purposes.
  12. \ -----------------------------------------------
  13. \ We are plotting a difference equation:
  14. \
  15. \     x := x - (y/a)
  16. \     y := y + (x/b)
  17. \
  18. \ This should give us nested ellipses with tilted axes.
  19. \ However, we are deliberately causing the calculations
  20. \ to overflow, which makes the screen output more interesting.
  21. \
  22. \ "WritePixel" (graphics 54) really slows us down; this program
  23. \ runs at about the same speed on an Apple IIe in double-hires
  24. \ (the Apple version is in assembly language, with table-driven
  25. \ screen calculations).  One of these days I will try to figure
  26. \ out how to access the bitmaps directly.
  27. \
  28. \ References:
  29. \  "Serendipitous Circles" by D. J. Anderson and W. F. Galway,
  30. \        BYTE, August 1977, page 70
  31. \  "Serendipitous Circles Explored" by Eduardo Kellerman,
  32. \        BYTE, April 1978, page 178
  33. \  "How Many Ways Can You Draw a Circle?" by James F. Blinn,
  34. \        DDJ Software Tools, September 1987, page 18
  35. \ -----------------------------------------------
  36.  
  37.  
  38. anew demomarker   \ forget back to here on reload
  39.  
  40. \ -----------------------------------------------
  41. \ We'll use a few variables ...
  42. \ -----------------------------------------------
  43. global KeyFlag
  44. global MouseFlag
  45. global CurrentRport
  46. global CurrentVP
  47.  
  48. \ -----------------------------------------------
  49. \ Linear congruential random number generator.
  50. \ These numbers were arbitrarily chosen.
  51. \ They seem to work ok for this program, but
  52. \ I would recommend thorough testing before using
  53. \ them in a production system.  See Knuth, vol. 2
  54. \ -----------------------------------------------
  55. variable seed
  56.  
  57. \ Return a "random" 32-bit number.
  58. : rnd  ( -- n )  seed @ 231773 * 171487 + dup seed ! ;
  59.  
  60. \ Set seed to unpredictable value
  61. : randomize ( -- )  CurrentTime xor seed ! ;
  62.  
  63. \ Return signed 16-bit value between 0 and |n|-1, with same sign as n
  64. : random ( n -- n' )  rnd 65535 and * -16 scale ;
  65.  
  66.  
  67. \ -----------------------------------------------
  68. \ A few useful routines
  69. \ -----------------------------------------------
  70.  
  71. \ truncate signed 32-bit value to signed 16-bit value
  72. \ (there must be a better way to do this)
  73. : trunc ( n -- w) 16 scale -16 scale ;
  74.  
  75. \ pack 4 numbers (0..15) into rgb value
  76. : rgb  ( a b c -- 0abc )
  77.    swap rot 16* or 16* or ;
  78.  
  79. \ -----------------------------------------------
  80. \ color table, with supporting routines
  81. \ -----------------------------------------------
  82. hex
  83. create ColorTable
  84.    00 00 00 rgb w,
  85.    0f 0f 0f rgb w,
  86.    00 08 0f rgb w,
  87.    08 00 0f rgb w,
  88.    00 0f 08 rgb w,
  89.    08 0f 00 rgb w,
  90.    0f 00 08 rgb w,
  91.    0f 08 00 rgb w,
  92. decimal
  93.  
  94. : RandomizeColors ( -- )   \ randomize values in ColorTable
  95.    8 1 do                  \ leave color 0 alone
  96.       4096 random
  97.       ColorTable i 2* + w!
  98.    loop ;
  99.  
  100. : NewColors ( -- )         \ randomize screen colors
  101.    RandomizeColors
  102.    CurrentVP WaitBOVP
  103.    CurrentVP ColorTable 8 LoadRGB4 ;
  104.  
  105.  
  106. \ -----------------------------------------------
  107. \ define custom screen and window
  108. \ -----------------------------------------------
  109.  
  110.  struct NewScreen  demoscrn
  111.       demoscrn  InitScreen       \ copy default values to new screen
  112.       320 demoscrn +nsWidth w!
  113.       200 demoscrn +nsHeight w!
  114.       3   demoscrn +nsDepth  w!   \ # bitplanes
  115.       0   demoscrn +nsViewModes w!
  116.       CUSTOMSCREEN  demoscrn +nsType  w!
  117.  structend
  118.  
  119.  struct NewWindow  demowindow     \ define a window
  120.       demowindow  InitWindow      \ copy default values to new window
  121.         0 demowindow +nwLeftEdge w!
  122.         0 demowindow +nwTopEdge  w!
  123.       320 demowindow +nwWidth    w!
  124.       200 demowindow +nwHeight   w!
  125.       WINDOWCLOSE  ACTIVATE | GIMMEZEROZERO | RMBTRAP |
  126.                     demowindow +nwFlags !
  127.       fCLOSEWINDOW VANILLAKEY | MOUSEBUTTONS |
  128.                     demowindow +nwIDCMPFlags  !
  129.       CUSTOMSCREEN  demowindow +nwType w!  \  open on a custom screen
  130.  structend
  131.  
  132.  
  133. \ -----------------------------------------------
  134. \ Handle mouse and key events
  135. \ -----------------------------------------------
  136.  
  137. \ Do something if we detect mouse button
  138. : ProcessMouse ( mousecode -- )
  139.    case
  140.       SELECTDOWN     \ left mouse button: set flag for new display
  141.           of  TRUE to MouseFlag  endof
  142.       MENUDOWN       \ right mouse button: randomize screen colors
  143.           of  NewColors  FALSE to MouseFlag  endof
  144.    endcase ;
  145.  
  146. : CleanupDemo ( -- ) \ perform whatever cleanup is necessary before leaving
  147.    CurrentWindow @ CloseWindow
  148.    CurrentScreen @ CloseScreen ;
  149.  
  150. : GoodBye ( -- )     \ return to WorkBench or to Multi-Forth
  151.    ?turnkey if bye else abort then ;
  152.  
  153. : EndDemo ( -- )     \ action for when demo complete
  154.    CleanupDemo GoodBye ;
  155.  
  156. : DemoEvents ( -- )  \ check for IDCMP event; take appropriate action
  157.    GetEvent
  158.    case
  159.       fCLOSEWINDOW
  160.          of  EndDemo  endof
  161.       VANILLAKEY
  162.          of  ThisEvent +eCode w@  to KeyFlag  endof
  163.       MOUSEBUTTONS
  164.          of  ThisEvent +eCode w@  ProcessMouse  endof
  165.    endcase  ;
  166.  
  167.  
  168. \ -----------------------------------------------
  169. \ Translate weird numbers into window coordinates, and plot.
  170. \ -----------------------------------------------
  171. : plot  ( x y -- )
  172.    swap  320 *  -16 scale  160 +    \ calc X coord
  173.    swap  200 *  -16 scale  100 +    \ calc Y coord
  174.    CurrentRport !a1 !d1 !d0 graphics 54 ;
  175.  
  176. \ -----------------------------------------------
  177. \ We are plotting a difference equation:
  178. \
  179. \     x := x - (y/a)
  180. \     y := y + (x/a)
  181. \
  182. \ This should give us nested ellipses with tilted axes.
  183. \ However, we are deliberately causing the calculations
  184. \ to overflow, which makes the screen output more
  185. \ interesting.
  186. \ -----------------------------------------------
  187. : wow
  188.    randomize
  189.    begin
  190.       0 to KeyFlag  0 to MouseFlag  NewColors
  191.       99 random 1+                 \ generate random values, 1..99
  192.          rnd 0< if negate then     \ 
  193.       99 random 1+                 \
  194.          rnd 0< if negate then     \
  195.       locals| bb aa |
  196.       clr.window
  197.       256 0 do
  198. \        NewColors
  199.          CurrentRport  8 random   setapen
  200.          rnd trunc  rnd trunc
  201.          256 0 do
  202.             DemoEvents
  203.             swap over aa 100 */ - trunc
  204.             swap over bb 100 */ + trunc
  205.             2dup plot
  206.             KeyFlag MouseFlag or if leave then
  207.          loop  2drop
  208.          KeyFlag MouseFlag or if leave then
  209.       loop
  210.       KeyFlag 27 =   \ look for ESCAPE (is there an equate?)
  211.    until ;
  212.  
  213. \ -----------------------------------------------
  214. \ main entry point for turnkey system
  215. \ -----------------------------------------------
  216.  
  217. : orbits  ( -- )
  218.    0" Multi-Forth version 1.21 "  demoscrn +nsDefaultTitle !
  219.    0" Orbits "  demowindow +nwTitle  !
  220.    demoscrn OpenScreen  verifyscreen         \ open a 4 bit plane screen
  221.    CurrentScreen @  demowindow +nwScreen  !  \ store screen ptr in window
  222.    demowindow OpenWindow  verifywindow       \ open demo window
  223.    CurrentWindow @ ViewPortAddress  to CurrentVP
  224.    Rport  to CurrentRport
  225.    ?turnkey if  on.error EndDemo resume  then
  226.    wow EndDemo ;
  227.  
  228. \ -----------------------------------------------
  229. \ instructive messages, in the style of the demos
  230. \ distributed with the Multi-Forth system
  231. \ -----------------------------------------------
  232.  
  233. cr ." ready for demo or turnkey. "
  234. cr ." enter:   orbits "
  235. cr
  236. cr ." turnkey with:   turnkey" 34 emit ."  orbits" 34 emit  ."   orbits"
  237.  
  238.  
  239.