home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1994 #1 / monster.zip / monster / PROG_GEN / FORTH_86.ZIP / PUZZLE.4TH < prev    next >
Text File  |  1994-01-04  |  3KB  |  109 lines
  1.  off  printload
  2. (  forget strt
  3. : strt ; )
  4. ( using puzzle.4th )
  5.  
  6.  unsplit cls
  7.  
  8. ( This is a program which was written hurriedly one evening to help with my 
  9. daughter's homework problem. If anything -- it shows the perils of not 
  10. documenting things at the moment they are written. The exact specification of 
  11. the problem we can no longer recall -- other than that it involves finding 
  12. " magic numbers" such that they can be split into integral divisors -  which 
  13. divisors add up to that number. 
  14.  
  15.   For example  496 =  1 + 2 + 4 + 8 + 16 + 248 + 124 + 62 + 31
  16.     where (2 x 248) = (4 x 124) = (8 x 62) = (16 x 31) = 496
  17.  
  18.     In fact it was a futile exercise as the next highest number is so 
  19. very large that it probably exceeds single precision range. Also -- there is 
  20. allegedly only one such additional number feasible.
  21.  
  22.     Be assured there is just ONE more number -- and it's VERY large -- 
  23. and maybe use this as an exercise in converting the program to double 
  24. precision -- or inventing a different algorithm. )
  25.  
  26. ( ) 20 const range
  27. ( ) 60 block valid
  28. ( ) 2 block ptr1
  29. ( ) 2 block sum
  30. 2 block orig
  31.  
  32. ( ******* 
  33. store valid value in array and update pointers
  34. ********* )
  35.  
  36. : store valid dup 1 swap +! ( inc count )
  37.               ptr1 @ + !    ( store result )
  38.               2 ptr1 +!     ( inc ptr1 ) ;
  39.  
  40. ( ******* 
  41. see if input numbers divide exactly - if so store in array 
  42. ********* )
  43.  
  44. : htest swap over /mod drop 0= if ( exact div -- NOS=number TOS=div )
  45.                                over over = 0= if store else drop then
  46.                               else drop then   ;
  47.  
  48. ( ******* 
  49. test input number with divisors from 2 through "range" 
  50. ********* )
  51.  
  52. : primes range 2 do dup i htest loop ( drop ) ;
  53.  
  54. ( ******* 
  55. initialise variables 
  56. ********* )
  57.  
  58. : init 58 0 do 0 valid i + ! 2 +loop 1 sum ! 
  59.     2 ptr1 ! ( first word is count ) dup orig ! ;
  60.  
  61. ( ******* 
  62. do division again to get other divisor 
  63. ********* )
  64.  
  65. : others valid @ dup + 2 do dup valid i + @ / dup range > if store 
  66.                                                   else drop 
  67.                                                   then 2 +loop ;
  68.  
  69. ( ******* 
  70. display contents of array "valid" 
  71. ********* )
  72.  
  73. : show valid @ dup + 2 do valid i + @ . ( crlf ) 2 +loop ;
  74.  
  75. ( ******* 
  76. add numbers in array 
  77. ********* )
  78.  
  79. : hadd valid @ dup + 2 do valid i + @ sum +! 2 +loop ;
  80.  
  81. ( ******* 
  82. display results for value passed in 
  83. ********* )
  84.  
  85. : tst init 
  86.       primes  others drop 
  87.        hadd sum @ orig @ - 0= if 1 . show orig @ 
  88. "                          gives number " crlf ." . crlf then ;
  89.     
  90. ( ******* 
  91. scan and TST numbers 1 through value passed in 
  92. ********* )
  93.  
  94. : cdoit crlf 1 do i tst loop ;
  95.  
  96. ( ******* 
  97. debugging stub -- display results for input number 
  98. ********* )
  99.  
  100. : parts init ( first word is count ) 
  101.       dup orig ! primes  others drop  1 . show hadd crlf sum @ " sum is " ." .
  102. ;
  103.  
  104. on printload
  105.  
  106. 1500 cdoit
  107.  
  108.  
  109.