testsource/sievefig.bif6809

   1 ( ARCHETYPICAL IMPLEMENTATION )
   2 ( OF THE SIEVE OF ERATOSTHENES )
   3 ( IN FORTH -- BIF, FIG --  )
   4 ( USING A LITTLE MORE )
   5 ( OF THE FORTH AND BIF IDIOMS. )
   6 ( COPYRIGHT 2015, 2019,
   7 ( JOEL MATTHEW REES )
   8 ( BY JOEL MATTHEW REES, )
   9 ( AMAGASAKI, JAPAN, 2015 )
  10 ( ALL RIGHTS RESERVED. )
  11 ( PERMISSION GRANTED BY THE )
  12 ( AUTHOR TO USE THIS CODE )
  13 ( FOR ANY PURPOSE,  )
  14 ( ON CONDITION THAT )
  15 ( SUBSTANTIAL USE  )
  16 ( SHALL RETAIN THIS COPYRIGHT )
  17 ( AND PERMISSION NOTICE. )
  18
  19 ( PERL-ESQUE, TOO. )
  20
  21 VOCABULARY SIEVE-LOCAL
  22 ( MAKE A LOCAL SYMBOL TABLE. )
  23 SIEVE-LOCAL DEFINITIONS
  24 ( SWITCH TO THE )
  25 ( LOCAL VOCABULARY. )
  26
  27
  28 256 CONSTANT MAXSIEVE
  29 MAXSIEVE 1 - 2 /
  30    CONSTANT FINALPASS
  31  -->
  32
  33
  34 5 CONSTANT DISPWIDTH
  35 ( ENOUGH DIGITS )
  36 ( TO DISPLAY MAXSIEVE )
  37
  38
  39 0 VARIABLE SIEVE
  40 ( OLD FORTHS DON'T PROVIDE A )
  41 ( DEFAULT BEHAVIOR FOR CREATE )
  42 ( GFORTH WILL LEAVE )
  43 ( THE ZERO THERE. )
  44 ( OLD FORTHS NEED )
  45 ( AN INITIAL VALUE. )
  46
  47    HERE SIEVE -
  48 ( OLD FORTHS DON'T PROVIDE )
  49 ( A CELL WIDTH. )
  50    CONSTANT CELLWIDTH
  51 ( TO SHOW HOW IT CAN BE DONE. )
  52
  53 CELLWIDTH MAXSIEVE SWAP - ALLOT
  54 ( ALLOCATE THE REST )
  55 ( OF THE BYTE ARRAY. )
  56
  57 : NOT-PRIME! ( ADR N -- )
  58 + 0 SWAP ! ;
  59
  60 : IS-PRIME? ( ADR N -- F )
  61 + @ ;
  62   -->
  63
  64
  65 : SIEVE-INIT ( ADR -- )
  66 0 OVER C!
  67 ( 0 IS NOT PRIME. )
  68 0 OVER 1+ C!
  69 ( 1 IS NOT PRIME. )
  70 ( SET FLAGS TO TRUE )
  71 ( FOR 2 TO FINALPASS. )
  72 2+ MAXSIEVE 2- -1 FILL
  73  ;
  74
  75
  76 : PRIME-PASS ( ADR PRIME -- )
  77 (  DOUBLE IS FIRST MULTIPLE )
  78 MAXSIEVE OVER DUP + DO
  79    OVER I NOT-PRIME!
  80    DUP +LOOP ( NEXT MULTIPLE )
  81 DROP ;
  82
  83 : FIND-PRIMES ( ADR -- )
  84 FINALPASS 2 DO
  85    DUP I IS-PRIME? IF
  86       I PRIME-PASS
  87    ENDIF
  88 LOOP ;
  89
  90 -->
  91
  92
  93
  94
  95
  96
  97 : COUNT-PRIMES ( ADR -- )
  98 ." COUNT: " .
  99 0 SWAP
 100 MAXSIEVE 0 DO
 101    DUP I IS-PRIME? IF
 102       SWAP 1+ SWAP
 103    ENDIF
 104 LOOP DROP CR
 105  ;
 106
 107
 108 : PRINT-ALL ( ADR -- )
 109 MAXSIEVE 0 DO
 110    I DISPWIDTH .R ." : IS "
 111    DUP I IS-PRIME? 0= IF
 112       ." NOT "
 113    ENDIF
 114    ." PRIME." CR
 115 LOOP
 116 DROP ;
 117
 118
 119 : PRINT-PRIMES ( ADR -- )
 120 MAXSIEVE 0 DO
 121    DUP I IS-PRIME?
 122    IF . ENDIF
 123 LOOP
 124 DROP CR ;
 125 -->
 126
 127
 128
 129
 130 BIF   DEFINITIONS
 131
 132 : SIEVEMAIN ( -- )
 133 [ SIEVE-LOCAL ]
 134 SIEVE SIEVE-INIT
 135 SIEVE FIND-PRIMES
 136 SIEVE PRINT-PRIMES
 137 SIEVE COUNT-PRIMES ;
 138
 139
 140 SIEVEMAIN
 141
 142