home *** CD-ROM | disk | FTP | other *** search
/ Hall of Fame / HallofFameCDROM.cdr / prog1 / 4th_86.lzh / HILSIER.4TH < prev    next >
Text File  |  1989-02-12  |  3KB  |  135 lines
  1. ( forget new
  2. : new ; )
  3. off printload 
  4.  
  5. 2 block n
  6. 2 n !
  7. ( 2 ' n 3 + @ b!)
  8.  
  9. 512 const h0
  10. 7 const maxcolr
  11. 2 block colr
  12. 2 block ii
  13. 2 block hh
  14. 2 block x
  15. 2 block y
  16. 2 block x00
  17. 2 block y00
  18. 2 block mag
  19.  
  20. : incx x @ hh @ + x ! ;
  21. : decx x @ hh @ - x ! ;
  22. : dec2x x @ hh @ 2 * - x ! ;
  23. : inc2x x @ hh @ 2 * + x ! ;
  24. : incy y @ hh @ + y ! ;
  25. : decy y @ hh @ - y ! ;
  26. : dec2y y @ hh @ 2 * - y ! ;
  27. : inc2y y @ hh @ 2 * + y ! ;
  28. : plot x @ y @ colr @ dline ;
  29. : hplot x @ 2 / y @ 2 / colr @ dline ;
  30. : setplot x @ y @ 0 dline ;
  31. : hsetplot x @ 2 / y @ 2 / 0 dline ;
  32.  
  33. : aa0 ;
  34. : bb0 ;
  35. : cc0 ;
  36. : dd0 ;
  37.  
  38. : AA dup 0> if
  39.      1- DD0 decx plot 
  40.      1- recurse decy plot     
  41.      1- recurse incx plot
  42.      1- BB0 then 1+ ;
  43.  
  44. : BB dup 0> if
  45.      1- CC0 incy plot 
  46.      1- recurse incx plot     
  47.      1- recurse decy plot
  48.      1- AA0 then 1+ ;
  49.  
  50. : CC dup 0> if
  51.      1- BB0 incx plot 
  52.      1- recurse incy plot     
  53.      1- recurse decx plot
  54.      1- DD0 then 1+ ;
  55.  
  56. : DD1 dup 0> if
  57.      1- AA0 decy plot 
  58.      1- recurse decx plot     
  59.      1- recurse incy plot
  60.      1- CC0 then 1+ ;
  61.  
  62. link aa0 aa link bb0 bb      link cc0 cc   link dd0 dd1
  63.  
  64. : swcolr
  65.        colr @ 1+ maxcolr /mod drop dup 0= if 1+ then colr ! ;
  66.  
  67. : hilb 0 colr !
  68.  
  69.       egam depth case 0 of 1 mag ! 2 n ! endof
  70.                         1 of 1 mag ! n ! endof
  71.                         2 of mag ! n ! endof endcase 
  72.  
  73.      0 ii !  h0  8 / hh !  hh @ 2 / 19 * dup 5 / 70h + x00 !  5 / 40h + y00 ! 
  74.  h0 2 / mag @ * hh !  ( modified hilb)
  75.  
  76.     begin  swcolr
  77.        ii @ 1+ ii !  
  78.        hh @ 2 / hh ! 
  79.     x00 @ hh @ 2 / + x00 !
  80.         y00 @ hh @ 2 / + y00 !
  81.        x00 @ x !  y00 @ y ! setplot 
  82.     ii @ AA drop
  83.     n @ ii @ - 0= end ;
  84.  
  85. : aaa0 ;
  86. : bbb0 ;
  87. : ccc0 ;
  88. : ddd0 ;
  89.  
  90. : AAA dup 0> if
  91.      1- recurse incx decy hplot 
  92.      1- BBB0 inc2x hplot     
  93.      1- DDD0 incx incy hplot
  94.      1- recurse then 1+ ;
  95.  
  96. : BBB dup 0> if
  97.      1- recurse decx decy hplot 
  98.      1- CCC0 dec2y hplot     
  99.      1- AAA0 incx decy hplot
  100.      1- recurse then 1+ ;
  101.  
  102. : CCC dup 0> if
  103.      1- recurse decx incy hplot 
  104.      1- DDD0 dec2x hplot     
  105.      1- BBB0 decx decy hplot
  106.      1- recurse then 1+ ;
  107.  
  108. : DDD1 dup 0> if
  109.      1- recurse incx incy hplot 
  110.      1- AAA0 inc2y hplot     
  111.      1- CCC0 decx incy hplot
  112.      1- recurse then 1+ ;
  113.  
  114. link aaa0 aaa link bbb0 bbb      link ccc0 ccc   link ddd0 ddd1
  115.  
  116. : sierp 0 colr !
  117.        egam depth case 0 of 1 mag ! 2 n ! endof
  118.                         1 of 1 mag ! n ! endof
  119.                         2 of mag ! n ! endof endcase 
  120.  
  121.      0 ii !  h0 8 / hh !  hh @ 19 * dup 4 / 140h + x00 !  5 / afh + y00 ! 
  122. h0 4 ( 8 ) / mag @ * hh !
  123.     begin  swcolr
  124.        ii @ 1+ ii !   x00 @ hh @ - x00 !  
  125.        hh @ 2 / hh !  y00 @ hh @ + y00 !
  126.        x00 @ x !  y00 @ y !  hsetplot 
  127.        ii @ AAA incx decy hplot drop
  128.        ii @ BBB decx decy hplot drop 
  129.        ii @ CCC decx incy hplot drop
  130.        ii @ DDD1 incx incy hplot drop
  131.  
  132.     n @ ii @ - 0= end ;
  133.  
  134.  
  135.