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 ( NEW FORTHS WILL LEAVE )
  43 ( THE ZERO THERE. )
  44 ( OLD FORTHS NEED )
  45 ( AN INITIAL VALUE. )
  46
  47 ( OLD FORTHS DON'T PROVIDE )
  48 ( A CELL WIDTH. )
  49   HERE SIEVE - DUP ( CELLWIDTH )
  50
  51 ( ALLOCATE THE REST )
  52 ( OF THE BYTE ARRAY. )
  53   MAXSIEVE SWAP - ALLOT
  54
  55 ( NOW DEFINE THE CONSTANT: )
  56   CONSTANT CELLWIDTH
  57
  58 : NOT-PRIME! ( ADR N -- )
  59 + 0 SWAP C! ;
  60
  61 : IS-PRIME? ( ADR N -- F )
  62 + C@ ;
  63   -->
  64
  65
  66 : SIEVE-INIT ( ADR -- )
  67 DUP 0 NOT-PRIME!
  68 DUP 1 NOT-PRIME!
  69 ( SET FLAGS TO TRUE )
  70 ( FOR 2 TO FINALPASS. )
  71 2+ MAXSIEVE 2- -1 FILL
  72  ;
  73
  74
  75 : PRIME-PASS ( ADR PRIME -- )
  76 (  DOUBLE IS FIRST MULTIPLE )
  77 MAXSIEVE OVER DUP + DO
  78    OVER I NOT-PRIME!
  79    DUP +LOOP ( NEXT MULTIPLE )
  80 DROP ;
  81
  82 : FIND-PRIMES ( ADR -- )
  83 FINALPASS 2 DO
  84    DUP I IS-PRIME? IF
  85       I PRIME-PASS
  86    ENDIF
  87 LOOP ;
  88
  89 -->
  90
  91
  92
  93
  94
  95
  96
  97
  98 : COUNT-PRIMES ( ADR -- )
  99 0 SWAP
 100 MAXSIEVE 0 DO
 101    DUP I IS-PRIME? IF
 102       SWAP 1+ SWAP
 103    ENDIF
 104 LOOP DROP
 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 I . 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 CR
 137 ." COUNT: "
 138 SIEVE COUNT-PRIMES . CR ;
 139
 140
 141 SIEVEMAIN
 142
 143
 144 ( 8192: 8 SECONDS TO FIND )
 145 ( 3 TO COUNT )
 146 ( XROAR, NORMAL CLOCK )
 147