(*
* LANGUAGE : ANS Forth with extensions
* PROJECT : Forth Environments
* DESCRIPTION : Ant colony optimization of Travelling Salesman Problem
* CATEGORY : Utility
* AUTHOR : Marcel Hendrix
* LAST CHANGE : May 26, 2005, Marcel Hendrix
*)

NEEDS -miscutil
NEEDS -fsl_util

REVISION -ants "--- Ant colony Optim. Version 1.00 ---"

PRIVATES

DOC
(*
Ant Colony Optimization (ACO) studies artificial systems that take
inspiration from the behavior of real ant colonies. ACO is used to solve
discrete optimization problems.

In the real world, ants initially wander randomly, and when having found
food, return to their colony while laying down pheromone trails. If other ants
find such a path, they are likely to follow the trail, returning and thus
reinforcing it if they eventually find food. Thus, when one ant finds a good
path from the colony to a food source, other ants are more likely to follow
that same path, and positive feedback eventually leaves all the ants
following it. The idea of ACO is to mimic this behavior with "simulated ants"
walking around a graph that represents the problem to solve.

The algorithm
-------------
The artificial ant is in this case an agent which moves from city to city on a
TSP graph. The agent's travelling strategy is based on a probabilistic
function that takes two things into account. Firstly, it counts the edges it
has travelled, accumulating their length and secondly, it senses the trail
(pheromone) left behind by other ant agents. Each agent modifies the
environment in two different ways :

1. Local trail updating: As the ant moves between cities it updates the
amount of pheromone on each traversed edge
2. Global trail updating: When all ants have completed a tour the ant that
found the shortest route updates the edges in its path The purpose of
local updating is mainly to avoid very strong pheromone edges to be
chosen by every ant, hence increasing exploration and hopefully
avoiding locally optimal solutions. The global updating function gives
the shortest path higher reinforcement, i.e., the amount of pheromone
on the edges of the path is increased. There are three main ideas that
this ant colony algorithm has adopted from real ant colonies:

a. The ants have a probabilistic preference for paths with high
pheromone value
b. Shorter paths tend to have a higher rate of growth in pheromone
value
c. It uses an indirect communication system through pheromone in
edges
In addition the agents are provided with a few capabilities not present in real ants, but likely to help solving the problem at hand. For example, each
ant is able to determine how far away cities are, and they all have a memory
of which cities already visited.

The probability that a city is chosen is a function of how close the city is and how much pheromone already exists on that trail. Once a tour has been completed (i.e. each city has been visited exactly once by the ant) the edges are calculated and then each ant deposits pheromone on the complete tour. The pheromone concentration on the edge between city I and J is multiplied by p(RHO), the evaporation constant. This value can be set between 0 and 1.
The pheromone evaporates more rapidly for lower values.

The amount of pheromone an ant k deposits on an edge is defined by the length of the tour created by this ant. Intuitively short tours will result in higher levels of pheromone deposited on the edges.
*)
ENDDOC

-- Control parameters

0.3e FVALUE DECAY_FACTOR
1e FVALUE TWEAK ( does almost nothing! )
#30 VALUE #ANTS ( 30 / 70 )
#70 VALUE #ITERS ( 70 / 300 )
0 VALUE #CITIES

INTEGER DMATRIX node{{ PRIVATE
DOUBLE DMATRIX distance{{

: distance ( F: -- r ) ( a b -- )
LOCALS| b a |
node{{ a 0 }} @
node{{ b 0 }} @ - S>F FSQR
node{{ a 1 }} @
node{{ b 1 }} @ - S>F FSQR F+ FSQRT ;

: BUILD-DISTANCE ( -- )
#CITIES 0 ?DO #CITIES I ?DO J I distance
FDUP distance{{ J I }} DF!
distance{{ I J }} DF!
LOOP
LOOP ;

0 [IF] S" original.frt" INCLUDED
[ELSE] S" kroA100.frt" INCLUDED
\ S" function.frt" INCLUDED
[THEN]

-- Global data ---------------------------------------------------------------------------------------------------

#CITIES #CITIES DOUBLE MATRIX pheromone{{ PRIVATE
DOUBLE DARRAY objectiveValue{ PRIVATE
DOUBLE DARRAY p/d{ PRIVATE

0e FVALUE BestObjectiveValue PRIVATE
0e FVALUE START_PHEROMONE PRIVATE
0e FVALUE MINIMUM_PHEROMONE PRIVATE

-- Data for each ant ------------------------------------------------------------------------------------------

INTEGER DMATRIX tour{{ -- visited cities in order
INTEGER DMATRIX notYetVisited{{ PRIVATE -- not yet visited cities <> -1

: getDistance ( from to -- ) ( F: -- d ) distance{{ -ROT }} DF@ ; PRIVATE

: StartAntColony ( -- )
1e64 TO BestObjectiveValue
0e #CITIES 1- 0 ?DO I I 1+ getDistance F+ LOOP
#CITIES 1- 0 getDistance F+ 1/F TO START_PHEROMONE

START_PHEROMONE 1e-4 F* TO MINIMUM_PHEROMONE
START_PHEROMONE pheromone{{ fillmat

objectiveValue{ #ANTS }malloc malloc-fail?
p/d{ #CITIES }malloc malloc-fail? OR
tour{{ #ANTS #CITIES }}malloc malloc-fail? OR
notYetVisited{{ #ANTS #CITIES }}malloc malloc-fail? OR ABORT" StartAntColony :: out of core" ; PRIVATE

: setObjectiveValue ( ant -- )
>S
objectiveValue{ S } DUP DF@
F0= IF 0e #CITIES 1- 0 ?DO tour{{ S I }} 2@ getDistance F+ LOOP
\ connect last to first city
tour{{ S #CITIES 1- }} @ tour{{ S> 0 }} @ getDistance F+ ( addr) DF!
ELSE -S DROP
ENDIF ; PRIVATE

-- prepare ant
: newRound ( ant -- )
LOCAL ant
0e objectiveValue{ ant } DF!
#CITIES 0 ?DO -1 tour{{ ant I }} ! LOOP
#CITIES 0 ?DO I notYetvisited{{ ant I }} ! LOOP ; PRIVATE

: addPheromone ( from to -- ) ( F: phero -- ) pheromone{{ -ROT 3DUP FDUP }} DF+! SWAP }} DF+! ; PRIVATE
: getPheromone ( from to -- ) ( F: -- phero ) pheromone{{ -ROT }} DF@ ; PRIVATE

-- add pheromone to all edges
: (layPheromone) ( F: p -- ) ( ant -- )
LOCAL ant
FLOCAL p
#CITIES 1- 0 ?DO tour{{ ant I }} 2@ p addPheromone LOOP
tour{{ ant #CITIES 1- }} @ tour{{ ant 0 }} @ p addPheromone ; PRIVATE

: layPheromone ( ant -- ) DECAY_FACTOR objectiveValue{ OVER } DF@ F/ (layPheromone) ; PRIVATE

: AllAntsMark ( -- )
#ANTS 0 ?DO ( MINIMUM_PHEROMONE objectiveValue{ I } DF@ F/ )
START_PHEROMONE
I (layPheromone)
LOOP ; PRIVATE

: findWay ( ant -- )
#CITIES CHOOSE 0 LOCALS| pos sel ant | \ random starting point
0e 0e FLOCALS| 1/sum vrandom |
sel tour{{ ant 0 }} !
-1 notYetVisited{{ ant sel }} ! \ strike from list
#CITIES
1 ?DO \ for all unvisited cities
0e ( sum ) \ Sum priorities of all unvisited cities
#CITIES 0 ?DO notYetVisited{{ ant I }} @ TO pos
pos 0>= IF tour{{ ant J 1- }} @ pos
2DUP getPheromone TWEAK F* getDistance F/
FDUP p/d{ pos } DF! F+ ( +sum)
ENDIF
LOOP 1/F TO 1/sum
FRANDOM TO vrandom \ Monte-Carlo choice
0e ( act ) \ probabilistic choice
#CITIES 0 ?DO notYetVisited{{ ant I }} @ TO pos
pos 0>= IF p/d{ pos } DF@ 1/sum F* F+ ( +act)
vrandom FOVER F< IF pos TO sel LEAVE ENDIF
ENDIF
LOOP FDROP
sel tour{{ ant I }} ! \ remember chosen city
-1 notYetVisited{{ ant sel }} ! \ don't visit it again
LOOP
ant setObjectiveValue ; PRIVATE

: doDecay ( -- )
DECAY_FACTOR F0= ?EXIT
pheromone{{ ADIMS *
0 ?DO DUP DF@ [ 1e DECAY_FACTOR F- ] FLITERAL F*
MINIMUM_PHEROMONE FMAX DF!+
LOOP DROP ; PRIVATE

: getBestAnt ( -- index )
0 LOCAL best
#ANTS 0 ?DO objectiveValue{ I } DF@
FDUP BestObjectiveValue F< IF TO BestObjectiveValue I TO best
ELSE FDROP
ENDIF
LOOP best ; PRIVATE

: solveTsp ( -- )
0 LOCAL iteration
BEGIN iteration #ITERS <
WHILE 1 +TO iteration
#ANTS 0 ?DO I newRound \ initialize ant
I findWay \ let ant loose
LOOP
allAntsMark
doDecay
getBestAnt layPheromone
REPEAT ;

: .PARAMETERS ( -- )
CR ." DECAY_FACTOR " DECAY_FACTOR F.N1
CR ." TWEAK " TWEAK F.N1
CR ." #ANTS " #ANTS DEC.
CR ." #ITERS " #ITERS DEC. ;

: .BEST-TOUR ( ant -- )
#digits >S print-width >S 3 TO #digits #25 TO print-width
CR ." Best tour: " tour{{ SWAP DUP 0 #CITIES 1- }}print[]
S> TO print-width S> TO #digits ; PRIVATE

: ANTS ( -- )
.PARAMETERS
4 0 DO CR TIMER-RESET
StartAntColony solveTsp
." Best value: " BestObjectiveValue F.N1 ." , " .ELAPSED
LOOP
getBestAnt .BEST-TOUR ;

: ITER-TEST ( max min -- )
DUP TO #ITERS .PARAMETERS
?DO
I TO #ITERS StartAntColony solveTsp
CR ." iters = " I 5 .R ." best value: " BestObjectiveValue F.N1
#10 +LOOP ;

\ NAME: kroA100, 100-city problem A (Krolak/Felts/Nelson)
\ Best distance is 21282

#100 TO #CITIES

distance{{ #CITIES #CITIES }}malloc

node{{ #CITIES 2 }}FREAD
1380 939
2848 96
3510 1671
457 334
3888 666
984 965
2721 1482
1286 525
2716 1432
738 1325
1251 1832
2728 1698
3815 169
3683 1533
1247 1945
123 862
1234 1946
252 1240
611 673
2576 1676
928 1700
53 857
1807 1711
274 1420
2574 946
178 24
2678 1825
1795 962
3384 1498
3520 1079
1256 61
1424 1728
3913 192
3085 1528
2573 1969
463 1670
3875 598
298 1513
3479 821
2542 236
3955 1743
1323 280
3447 1830
2936 337
1621 1830
3373 1646
1393 1368
3874 1318
938 955
3022 474
2482 1183
3854 923
376 825
2519 135
2945 1622
953 268
2628 1479
2097 981
890 1846
2139 1806
2421 1007
2290 1810
1115 1052
2588 302
327 265
241 341
1917 687
2991 792
2573 599
19 674
3911 1673
872 1559
2863 558
929 1766
839 620
3893 102
2178 1619
3822 899
378 1048
1178 100
2599 901
3416 143
2961 1605
611 1384
3113 885
2597 1830
2586 1286
161 906
1429 134
742 1025
1625 1651
1187 706
1787 1009
22 987
3640 43
3756 882
776 392
1724 1642
198 1810
3950 1558

BUILD-DISTANCE

\ EOF

Result:

FORTH> ANTS
DECAY_FACTOR 300 m
TWEAK 1
#ANTS 30
#ITERS 70
Best value: 28.556472 K, 0.123 seconds elapsed.
Best value: 27.925072 K, 0.124 seconds elapsed.
Best value: 27.550012 K, 0.124 seconds elapsed.
Best value: 29.279056 K, 0.124 seconds elapsed.
Best tour:
75 32 12 36 4 51 77 95 47 99 70 40 37 23 17 78 52 87 15 21 93 65 64 3 25 ...
69 41 88 30 79 55 96 74 18 89 48 5 62 0 57 66 27 92 50 60 24 80 68 63 39 ...
53 1 43 49 72 67 84 29 38 28 33 54 82 11 6 8 56 19 26 85 34 61 59 22 97 ...
90 44 10 16 14 58 73 20 71 9 83 98 35 31 46 13 2 42 45 86 81 94 7 91 76 ok
FORTH>

Marcel Hendrix schrieb am Mittwoch, 27. September 2023 um 19:55:58 UTC+2:
> \ NAME: kroA100, 100-city problem A (Krolak/Felts/Nelson)

Nice to see some refreshing new ideas in Forth!

Only as side remark, an intro to genetic programming:
https://www.researchgate.net/publication/326459163_Genetic_algorithms_in_Forth
(click on Download Pdf)

Le mercredi 27 septembre 2023 à 17:53:22 UTC, Marcel Hendrix a écrit :
> (*
> * LANGUAGE : ANS Forth with extensions
> * PROJECT : Forth Environments
> * DESCRIPTION : Ant colony optimization of Travelling Salesman Problem
> * CATEGORY : Utility
> * AUTHOR : Marcel Hendrix
> * LAST CHANGE : May 26, 2005, Marcel Hendrix
> *)
>
>
> NEEDS -miscutil
> NEEDS -fsl_util
>
> REVISION -ants "--- Ant colony Optim. Version 1.00 ---"
>
> PRIVATES
>
> DOC
> (*
> Ant Colony Optimization (ACO) studies artificial systems that take
> inspiration from the behavior of real ant colonies. ACO is used to solve
> discrete optimization problems.
>
> In the real world, ants initially wander randomly, and when having found
> food, return to their colony while laying down pheromone trails. If other ants
> find such a path, they are likely to follow the trail, returning and thus
> reinforcing it if they eventually find food. Thus, when one ant finds a good
> path from the colony to a food source, other ants are more likely to follow
> that same path, and positive feedback eventually leaves all the ants
> following it. The idea of ACO is to mimic this behavior with "simulated ants"
> walking around a graph that represents the problem to solve.
>
> The algorithm
> -------------
> The artificial ant is in this case an agent which moves from city to city on a
> TSP graph. The agent's travelling strategy is based on a probabilistic
> function that takes two things into account. Firstly, it counts the edges it
> has travelled, accumulating their length and secondly, it senses the trail
> (pheromone) left behind by other ant agents. Each agent modifies the
> environment in two different ways :
>
> 1. Local trail updating: As the ant moves between cities it updates the
> amount of pheromone on each traversed edge
> 2. Global trail updating: When all ants have completed a tour the ant that
> found the shortest route updates the edges in its path The purpose of
> local updating is mainly to avoid very strong pheromone edges to be
> chosen by every ant, hence increasing exploration and hopefully
> avoiding locally optimal solutions. The global updating function gives
> the shortest path higher reinforcement, i.e., the amount of pheromone
> on the edges of the path is increased. There are three main ideas that
> this ant colony algorithm has adopted from real ant colonies:
>
> a. The ants have a probabilistic preference for paths with high
> pheromone value
> b. Shorter paths tend to have a higher rate of growth in pheromone
> value
> c. It uses an indirect communication system through pheromone in
> edges
>
> In addition the agents are provided with a few capabilities not present in real ants, but likely to help solving the problem at hand. For example, each
> ant is able to determine how far away cities are, and they all have a memory
> of which cities already visited.
>
> The probability that a city is chosen is a function of how close the city is and how much pheromone already exists on that trail. Once a tour has been completed (i.e. each city has been visited exactly once by the ant) the edges are calculated and then each ant deposits pheromone on the complete tour. The pheromone concentration on the edge between city I and J is multiplied by p(RHO), the evaporation constant. This value can be set between 0 and 1.
> The pheromone evaporates more rapidly for lower values.
>
> The amount of pheromone an ant k deposits on an edge is defined by the length of the tour created by this ant. Intuitively short tours will result in higher levels of pheromone deposited on the edges.
> *)
> ENDDOC
>
> -- Control parameters
>
> 0.3e FVALUE DECAY_FACTOR
> 1e FVALUE TWEAK ( does almost nothing! )
> #30 VALUE #ANTS ( 30 / 70 )
> #70 VALUE #ITERS ( 70 / 300 )
> 0 VALUE #CITIES
>
> INTEGER DMATRIX node{{ PRIVATE
> DOUBLE DMATRIX distance{{
>
> : distance ( F: -- r ) ( a b -- )
> LOCALS| b a |
> node{{ a 0 }} @
> node{{ b 0 }} @ - S>F FSQR
> node{{ a 1 }} @
> node{{ b 1 }} @ - S>F FSQR F+ FSQRT ;
>
> : BUILD-DISTANCE ( -- )
> #CITIES 0 ?DO #CITIES I ?DO J I distance
> FDUP distance{{ J I }} DF!
> distance{{ I J }} DF!
> LOOP
> LOOP ;
>
> 0 [IF] S" original.frt" INCLUDED
> [ELSE] S" kroA100.frt" INCLUDED
> \ S" function.frt" INCLUDED
> [THEN]
>
> -- Global data ---------------------------------------------------------------------------------------------------
>
> #CITIES #CITIES DOUBLE MATRIX pheromone{{ PRIVATE
> DOUBLE DARRAY objectiveValue{ PRIVATE
> DOUBLE DARRAY p/d{ PRIVATE
>
> 0e FVALUE BestObjectiveValue PRIVATE
> 0e FVALUE START_PHEROMONE PRIVATE
> 0e FVALUE MINIMUM_PHEROMONE PRIVATE
>
> -- Data for each ant ------------------------------------------------------------------------------------------
>
> INTEGER DMATRIX tour{{ -- visited cities in order
> INTEGER DMATRIX notYetVisited{{ PRIVATE -- not yet visited cities <> -1
>
> : getDistance ( from to -- ) ( F: -- d ) distance{{ -ROT }} DF@ ; PRIVATE
>
> : StartAntColony ( -- )
> 1e64 TO BestObjectiveValue
> 0e #CITIES 1- 0 ?DO I I 1+ getDistance F+ LOOP
> #CITIES 1- 0 getDistance F+ 1/F TO START_PHEROMONE
>
> START_PHEROMONE 1e-4 F* TO MINIMUM_PHEROMONE
> START_PHEROMONE pheromone{{ fillmat
>
> objectiveValue{ #ANTS }malloc malloc-fail?
> p/d{ #CITIES }malloc malloc-fail? OR
> tour{{ #ANTS #CITIES }}malloc malloc-fail? OR
> notYetVisited{{ #ANTS #CITIES }}malloc malloc-fail? OR ABORT" StartAntColony :: out of core" ; PRIVATE
>
> : setObjectiveValue ( ant -- )
> >S
> objectiveValue{ S } DUP DF@
> F0= IF 0e #CITIES 1- 0 ?DO tour{{ S I }} 2@ getDistance F+ LOOP
> \ connect last to first city
> tour{{ S #CITIES 1- }} @ tour{{ S> 0 }} @ getDistance F+ ( addr) DF!
> ELSE -S DROP
> ENDIF ; PRIVATE
>
> -- prepare ant
> : newRound ( ant -- )
> LOCAL ant
> 0e objectiveValue{ ant } DF!
> #CITIES 0 ?DO -1 tour{{ ant I }} ! LOOP
> #CITIES 0 ?DO I notYetvisited{{ ant I }} ! LOOP ; PRIVATE
>
> : addPheromone ( from to -- ) ( F: phero -- ) pheromone{{ -ROT 3DUP FDUP }} DF+! SWAP }} DF+! ; PRIVATE
> : getPheromone ( from to -- ) ( F: -- phero ) pheromone{{ -ROT }} DF@ ; PRIVATE
>
> -- add pheromone to all edges
> : (layPheromone) ( F: p -- ) ( ant -- )
> LOCAL ant
> FLOCAL p
> #CITIES 1- 0 ?DO tour{{ ant I }} 2@ p addPheromone LOOP
> tour{{ ant #CITIES 1- }} @ tour{{ ant 0 }} @ p addPheromone ; PRIVATE
>
> : layPheromone ( ant -- ) DECAY_FACTOR objectiveValue{ OVER } DF@ F/ (layPheromone) ; PRIVATE
>
> : AllAntsMark ( -- )
> #ANTS 0 ?DO ( MINIMUM_PHEROMONE objectiveValue{ I } DF@ F/ )
> START_PHEROMONE
> I (layPheromone)
> LOOP ; PRIVATE
>
> : findWay ( ant -- )
> #CITIES CHOOSE 0 LOCALS| pos sel ant | \ random starting point
> 0e 0e FLOCALS| 1/sum vrandom |
> sel tour{{ ant 0 }} !
> -1 notYetVisited{{ ant sel }} ! \ strike from list
> #CITIES
> 1 ?DO \ for all unvisited cities
> 0e ( sum ) \ Sum priorities of all unvisited cities
> #CITIES 0 ?DO notYetVisited{{ ant I }} @ TO pos
> pos 0>= IF tour{{ ant J 1- }} @ pos
> 2DUP getPheromone TWEAK F* getDistance F/
> FDUP p/d{ pos } DF! F+ ( +sum)
> ENDIF
> LOOP 1/F TO 1/sum
> FRANDOM TO vrandom \ Monte-Carlo choice
> 0e ( act ) \ probabilistic choice
> #CITIES 0 ?DO notYetVisited{{ ant I }} @ TO pos
> pos 0>= IF p/d{ pos } DF@ 1/sum F* F+ ( +act)
> vrandom FOVER F< IF pos TO sel LEAVE ENDIF
> ENDIF
> LOOP FDROP
> sel tour{{ ant I }} ! \ remember chosen city
> -1 notYetVisited{{ ant sel }} ! \ don't visit it again
> LOOP
> ant setObjectiveValue ; PRIVATE
>
> : doDecay ( -- )
> DECAY_FACTOR F0= ?EXIT
> pheromone{{ ADIMS *
> 0 ?DO DUP DF@ [ 1e DECAY_FACTOR F- ] FLITERAL F*
> MINIMUM_PHEROMONE FMAX DF!+
> LOOP DROP ; PRIVATE
>
> : getBestAnt ( -- index )
> 0 LOCAL best
> #ANTS 0 ?DO objectiveValue{ I } DF@
> FDUP BestObjectiveValue F< IF TO BestObjectiveValue I TO best
> ELSE FDROP
> ENDIF
> LOOP best ; PRIVATE
>
> : solveTsp ( -- )
> 0 LOCAL iteration
> BEGIN iteration #ITERS <
> WHILE 1 +TO iteration
> #ANTS 0 ?DO I newRound \ initialize ant
> I findWay \ let ant loose
> LOOP
> allAntsMark
> doDecay
> getBestAnt layPheromone
> REPEAT ;
>
> : .PARAMETERS ( -- )
> CR ." DECAY_FACTOR " DECAY_FACTOR F.N1
> CR ." TWEAK " TWEAK F.N1
> CR ." #ANTS " #ANTS DEC.
> CR ." #ITERS " #ITERS DEC. ;
>
> : .BEST-TOUR ( ant -- )
> #digits >S print-width >S 3 TO #digits #25 TO print-width
> CR ." Best tour: " tour{{ SWAP DUP 0 #CITIES 1- }}print[]
> S> TO print-width S> TO #digits ; PRIVATE
>
> : ANTS ( -- )
> .PARAMETERS
> 4 0 DO CR TIMER-RESET
> StartAntColony solveTsp
> ." Best value: " BestObjectiveValue F.N1 ." , " .ELAPSED
> LOOP
> getBestAnt .BEST-TOUR ;
>
> : ITER-TEST ( max min -- )
> DUP TO #ITERS .PARAMETERS
> ?DO
> I TO #ITERS StartAntColony solveTsp
> CR ." iters = " I 5 .R ." best value: " BestObjectiveValue F.N1
> #10 +LOOP ;
>
> :ABOUT ." Try: ANTS" ;
>
> .ABOUT -ants CR
> DEPRIVE
>
> (* End of Source *)
Hi,
Very nice.
I haven't programmed ACO yet. It is in my plan. I have written a program for PSO and I haven't posted here yet.
There is a good book: Clever Algorithms .... where the author J. Brownlee presents several intelligent (inspired by nature) algorithms.
The programs in the book are in ruby language. (the programs are readable and easy).
Look at: https://github.com/clever-algorithms/CleverAlgorithms.
Have good discoveries
Bye

On Wednesday, September 27, 2023 at 8:31:20 PM UTC+2, minforth wrote:
> Only as side remark, an intro to genetic programming:
> https://www.researchgate.net/publication/326459163_Genetic_algorithms_in_Forth
> (click on Download Pdf)

They forgot to quote Sergei Baranoff.

(*
* LANGUAGE : ANS Forth
* PROJECT : Forth Environments
* DESCRIPTION : Playing with genetic algorithms
* CATEGORY : Game
* AUTHOR : Marcel Hendrix
* LAST CHANGE : Sunday, February 24, 2013, 16:01, Marcel Hendrix, needs (( and ))
* LAST CHANGE : February 7th, 1993, Marcel Hendrix, ANSification
* LAST CHANGE : October 28, 1992, Marcel Hendrix
*)

NEEDS -miscutil ( defer is random choose exec: exec; ?at )
NEEDS -arrays ( array )
NEEDS -strings ( $array new$array )

DECIMAL

( *
Inspired by an impromptu talk of Sergei Baranoff at EuroForth '92.
Sergei did not explain HOW his program worked, so I implemented an
approximation to it -- mutated badly, no doubt.
* )

0 VALUE mill

: .WINDMILL AT-XY \ <x> <y> --- <>
mill 3 AND CASE
0 OF ." | |" ENDOF
1 OF ." \ /" ENDOF
2 OF ." - -" ENDOF
3 OF ." / \" ENDOF
ENDCASE
mill 1+ TO mill ;

DEFER SHOULD

5 CONSTANT max-words
24 CONSTANT max-tokens

max-words ARRAY program
max-tokens $ARRAY names

: NOP ;
: FILL-STACK 20 0 DO RANDOM LOOP ;
: CHECK-STACK DEPTH 20 = ;
: CLEAR-STACK DEPTH 0 ?DO DROP LOOP ;

: / DUP IF / ELSE 2DROP -1 THEN ;
: MOD DUP IF MOD ELSE 2DROP -1 THEN ;

: EXECUTE-TOKEN max-tokens 1- MIN \ <token#> --- <>
EXEC:
NOP
DUP SWAP DROP ROT OVER
+ - 1+ 1- 2+ 2- 2/
ABS NEGATE MAX MIN
AND INVERT OR XOR
* / MOD
EXEC; ;

8 NEW$ARRAY names

S" NOP" TO 0 names S" DUP" TO 1 names S" SWAP" TO 2 names
S" DROP" TO 3 names S" ROT" TO 4 names S" OVER" TO 5 names
S" +" TO 6 names S" -" TO 7 names S" 1+" TO 8 names
S" 1-" TO 9 names S" 2+" TO 10 names S" 2-" TO 11 names
S" 2/" TO 12 names S" ABS" TO 13 names S" NEGATE" TO 14 names
S" MAX" TO 15 names S" MIN" TO 16 names S" AND" TO 17 names
S" INVERT" TO 18 names S" OR" TO 19 names S" XOR" TO 20 names
S" *" TO 21 names S" /" TO 22 names S" MOD" TO 23 names

: .NAME? max-tokens 1- MIN DUP \ <index> --- <boolean>
0= IF DROP FALSE EXIT
THEN \ skip NOPs
names TYPE 2 SPACES TRUE ;

: DO-PROGRAM max-words 0 DO I program EXECUTE-TOKEN
LOOP ;

: TEST 0 0 0 0 seed \ <> --- <bool>
LOCALS| oldseed olddepth top second third |

CLEAR-STACK FILL-STACK SHOULD

DEPTH TO olddepth oldseed TO seed
TO top TO second TO third \ save three numbers

CLEAR-STACK FILL-STACK DO-PROGRAM

DEPTH olddepth <> IF CLEAR-STACK FALSE EXIT THEN
top = SWAP second = AND SWAP third = AND >R
CLEAR-STACK R> ;

\ The new program is tested 40 times

: TESTS 40 0 DO \ <> --- <bool>
TEST 0= IF UNLOOP FALSE EXIT
THEN
LOOP
TRUE ;

0 VALUE tries

: MUTATE CR 0 TO tries
max-words 0 DO 0 TO I program LOOP
BEGIN
TESTS 0 WHILE
max-tokens CHOOSE TO (( max-words CHOOSE )) program
tries 1+ TO tries
tries 31 AND 31 = IF 0 ?AT NIP .WINDMILL THEN
KBHIT?
UNTIL THEN
KEY? IF KEY DROP THEN
CR tries . ." tries." ;

: .TEXT 3 LOCALS| #out |
CR ." : PROGRAM "
max-words 0 DO
#out 3 = IF CR 4 SPACES 0 TO #out THEN
I program .NAME? IF #out 1+ TO #out THEN
LOOP
." ;" ;

: .PROGRAM MUTATE .TEXT ;

\ Enter a goal function here -----------------------------------
\ There may not be more than three (3) significant output values

:NONAME 1+ ; IS SHOULD

: .HELP
CR ." Fills an array with random Forth tokens and executes it in a"
CR ." controlled environment. If the ``goal'' is not met, a random"
CR ." substitution is made for one of the tokens (a mutation), and"
CR ." we try again."
CR ." Enter .PROGRAM to find a program that meets the spec of ``1+''"
CR ." :NONAME 2 + ; IS SHOULD is the way to define other goals." ;

.HELP

( * End of Source * )

On Wednesday, September 27, 2023 at 9:10:42 PM UTC+2, Marcel Hendrix wrote:
[..]
> They forgot to quote Sergei Baranoff.

Some examples.

Fills an array with random Forth tokens and executes it in a
controlled environment. If the ``goal'' is not met, a random
substitution is made for one of the tokens (a mutation), and
we try again.
Enter .PROGRAM to find a program that meets the spec of ``1+'
:NONAME 2 + ; IS SHOULD is the way to define other goals. ok

( I didn't claim the output was good! )

FORTH> .program
| |
813 tries.
: PROGRAM
INVERT 2+ 1-
NEGATE 1+ ; ok
FORTH> .program
\ /
1063 tries.
: PROGRAM
OVER DUP /
2- - ; ok
FORTH> .program
\ /
4247 tries.
: PROGRAM
DUP MAX 1+
DUP AND ; ok
FORTH> .program
\ /
4243 tries.
: PROGRAM
ROT SWAP ROT
SWAP 1+ ; ok

FORTH> :NONAME 3 * + ; IS SHOULD ok
FORTH> .PROGRAM
| |
225456 tries.
: PROGRAM
DUP OVER +
+ + ; ok

-marcel

On 27/09/2023 21:57, Ahmed MELAHI wrote:

> There is a good book: Clever Algorithms .... where the author J. Brownlee presents several intelligent (inspired by nature) algorithms.
> The programs in the book are in ruby language. (the programs are readable and easy).
> Look at: https://github.com/clever-algorithms/CleverAlgorithms.
> Have good discoveries
> Bye

Thank you, this looks quite interesting.

(*
* LANGUAGE : ANS Forth with extensions
* PROJECT : Forth Environments
* DESCRIPTION : ??????????
* CATEGORY : Google CodeJam
* AUTHOR : Marcel Hendrix
* LAST CHANGE : May 1, 2012, Marcel Hendrix
*)

NEEDS -miscutil

REVISION -all-your-base "--- ___________________ Version 0.00 ---"

PRIVATES

DOC
(*
Problem

In A.D. 2100, aliens came to Earth. They wrote a message in a cryptic language, and
next to it they wrote a series of symbols. We've come to the conclusion that the
symbols indicate a number: the number of seconds before war begins!

Unfortunately we have no idea what each symbol means. We've decided that each symbol
indicates one digit, but we aren't sure what each digit means or what base the aliens
are using. For example, if they wrote "ab2ac999", they could have meant "31536000" in
base 10 -- exactly one year -- or they could have meant "12314555" in base 6 -- 398951
seconds, or about four and a half days. We are sure of three things: the number is
positive; like us, the aliens will never start a number with a zero; and they aren't
using unary (base 1).

Your job is to determine the minimum possible number of seconds before war begins.

Input

The first line of input contains a single integer, T. T test cases follow. Each test
case is a string on a line by itself. The line will contain only characters in the 'a'
to 'z' and '0' to '9' ranges (with no spaces and no punctuation), representing the
message the aliens left us. The test cases are independent, and can be in different
bases with the symbols meaning different things.

Output

For each test case, output a line in the following format: Case #X: V Where X is the
case number (starting from 1) and V is the minimum number of seconds before war begins.

Limits

1 = T = 100 The answer will never exceed 1018

Small dataset

1 = the length of each line < 10

Large dataset

1 = the length of each line < 61

Input
3
11001001
cats
zig

Output
Case #1: 201
Case #2: 75
Case #3: 11

*)
ENDDOC

0 VALUE benching
0 VALUE hi
CREATE d #36 CHARS ALLOT

: wipe ( -- ) d #36 CHARS ERASE CLEAR hi ;
: +dig ( -- ) d hi + C! 1 +TO hi ;

: >dig? ( char -- char bool )
hi
BEGIN DUP
WHILE 1- 2DUP d + C@ = IF NIP TRUE EXIT ENDIF
REPEAT DROP FALSE ;

: twiddle ( addr -- ) DUP >R C@ R@ CHAR+ C@ R@ C! R> CHAR+ C! ;

: pars ( c-addr u -- )
BOUNDS DO I C@ >dig? IF DROP ELSE +dig ENDIF LOOP
d twiddle hi 2 MAX TO hi ;

: dig> ( n -- char ) DUP 9 > IF 7 + ENDIF '0' + ;

: eval ( c-addr u -- d )
2DUP pars 2DUP BOUNDS DO I C@ >dig? DROP dig> I C! LOOP
hi BASE ! 0. 2SWAP >NUMBER 2DROP DECIMAL ;

: next-line ( -- c-addr u ) REFILL 0= IF QUIT ENDIF BL WORD COUNT ;
: .. ( d case -- ) benching IF 3DROP EXIT ENDIF CR ." Case #" 1 .R ." : " 1 UD.R ;
: AYB ( -- )
TIMER-RESET
next-line EVALUATE 0 ?DO next-line eval I 1+ .. wipe LOOP
CR .ELAPSED ;

:ABOUT CR ." Try AYB -- followed by the input" ;

0 [IF]

AYB
100
11001001
cats
zig
howareyou
gentlemen
allyour
baseare
belongto
us
hahaha
102345678
111111111
z abcdefghi
tbto4ot
tcu
p59pp5i5a
45iui6i1f
opppaapoa
i2jv7
mggi2i2gn
1xxf3ppxa
wbv9b9bjp
ggydgy
8585885gg
wllwliw4l
vzyvzon2y
x1xfldrdl
drtpzco
i5xfx
qdjj3ajaj
3333
sgkaaggsg
osjoojjjo
sam
ytytswyvs
k11dgzz4
p9bbb
hnhnn11n1
33bb33333
g636nxgbn
1v4gj5
bvbb5bb7b
mnmnmmmmn
0bzqozzop
guuugg
6oo2kk3yj
igsb7rirb
g7e30e0g0
vr0b2
u nil4n45n4
8rhdd
nnhuunv2h
fzfxnyfx
ddcvvcvvd
0170cc0yk
frr
00unxwjsk
ffuuhf44f
d4dcc4kcz
7j66j6676
rri2
1js11jm1s
8grqgq68m
0hsjv1ggg
d us7ytusfy
csnnsc
7 u52
d05d5d05d
ptmp
x0g
yveesyvvy
izvvitvtz
127j5s9m
txx2t22x2
jkykjkyjy
22yy2
l xymymxxex
t88r5dt0k
8sxx6400o
iiixp
mk
bbo22b2bo
i3ffbvffb
mloz5z
39wmzvj
xbvxy9yyx
9oc2g24o
mmtytomtt
e sus
p2c
aae0qbveq
maqm02qoo
coefo1ojc
cz

[ELSE]

AYB
100
11001001
cats
zig
howareyou
gentlemen
allyour
baseare
belongto
us
hahaha
102345678
111111111
z abcdefghi
1023456789
abcdefghijklmno
pqrstuvwxyz
nowiknowmyabcs
nexttimewontyou
singwithme
wealsowouldhave
acceptednexttime
wontyouplaywithme
theleftmostdigit
isaonethenyoucount
upfromthere
donotforgetthatthe
resultscangetvery
bigsobecareful
goreadthelarge
inputforyearof
codejaminthefinal
fromlastyear
butremember
thecakeisalie
bbabbbbaaaaababbabbababbaabbbabaabbbabbaabaaaaaaaaaaaaaaaaaa
cabcccbcccbacbabbbaacabacaccacbcacaaab
dbdcaacdbccdadccbdbcbaaaaaaaaa
dbdecadeaaaaaaaaaaaaaaaaaa
bbdddaccccfdfffdaedcfdee
bfdfaeedagfeeddaaebfdb
gheafffdbgehdbaaaaaa
gfifidhbeagdgicfcab
baaaaaaaaaaaaaaaaaa
bkiedeikkebaigaieb
fekkehkdfheehdife
bggmimkaekmaahfgb
gfnmibedgfmjmgii
cedmfconbinibegk
noalgldkhgeaaaa
fpqghedfkemkkgp
cmahnhaeppialnk
beophokododmjpb
mecqfaaaaaaaaa
01234456789012345
abcdefghijklmno
soh4zzb
guu
5ccpp5acaiaipa
mnti3i3kik3
66
i4777
7gg2sg2sn
8x8x8xx8xece8cxx
44aaaaa4qqaqsqa4
0k00hh
33338c8y939
1444lmkskl1
0uuu0uu0uxxx0uxux0u0
zsssg
ii5di
jjj5d0j990
ueu
sgk9aggsgss
a8tauu80ttuu
d69h9
hwenwwnjw
ndd0
88
hnhnn11n11
rjjrrrrrjr
7oeq7e7
881j1i
20v4vv24bb7
hgghvhhgwwvh
pijjjth
kj7
o326223ov6
psq12z2q2
ccbwcwwwwbwwwwbbcbbb
eiedjj1ddev
ejegstggwed
ff9f
nnhuunv2h2h4
k333k3k3
uumuumummmmumummmmuu
ag7pa
y 8uonnff
aaa66a6a6aa66aaaaaaaa6aa666a6aa

[THEN]

.ABOUT -all-your-base CR
DEPRIVE

(* End of Source *)

(*
* LANGUAGE : ANS Forth with extensions
* PROJECT : Forth Environments
* DESCRIPTION : game
* CATEGORY : Google CodeJam
* AUTHOR : Marcel Hendrix
* LAST CHANGE : May 1, 2012, Marcel Hendrix
*)

NEEDS -miscutil

REVISION -all-your-base "--- ___________________ Version 0.00 ---"

PRIVATES

DOC
(*
Problem

In A.D. 2100, aliens came to Earth. They wrote a message in a cryptic
language, and next to it they wrote a series of symbols. We've come
to the conclusion that the symbols indicate a number: the number of
seconds before war begins!

Unfortunately we have no idea what each symbol means. We've decided
that each symbol indicates one digit, but we aren't sure what each
digit means or what base the aliens are using. For example, if they
wrote "ab2ac999", they could have meant "31536000" in base 10
-- exactly one year -- or they could have meant "12314555" in
base 6 -- 398951 seconds, or about four and a half days. We are
sure of three things: the number is positive; like us, the aliens
will never start a number with a zero; and they aren't using unary
(base 1).

Your job is to determine the minimum possible number of seconds
before war begins.

Input

The first line of input contains a single integer, T. T test cases
follow. Each test case is a string on a line by itself. The line
will contain only characters in the 'a' to 'z' and '0' to '9'
ranges (with no spaces and no punctuation), representing the
message the aliens left us. The test cases are independent,
and can be in different bases with the symbols meaning different
things.

Output

For each test case, output a line in the following format: Case #X: V
Where X is the case number (starting from 1) and V is the minimum number
of seconds before war begins.

Limits

1 = T = 100 The answer will never exceed 1018

Small dataset

1 = the length of each line < 10

Large dataset

1 = the length of each line < 61

Input
3
11001001
cats
zig

Output
Case #1: 201
Case #2: 75
Case #3: 11

*)
ENDDOC

0 VALUE benching
0 VALUE hi
CREATE d #36 CHARS ALLOT

: wipe ( -- ) d #36 CHARS ERASE CLEAR hi ;
: +dig ( -- ) d hi + C! 1 +TO hi ;

: >dig? ( char -- char bool )
hi
BEGIN DUP
WHILE 1- 2DUP d + C@ = IF NIP TRUE EXIT ENDIF
REPEAT DROP FALSE ;

: twiddle ( addr -- ) DUP >R C@ R@ CHAR+ C@ R@ C! R> CHAR+ C! ;

: pars ( c-addr u -- )
BOUNDS DO I C@ >dig? IF DROP ELSE +dig ENDIF LOOP
d twiddle hi 2 MAX TO hi ;

: dig> ( n -- char ) DUP 9 > IF 7 + ENDIF '0' + ;

: eval ( c-addr u -- d )
2DUP pars 2DUP BOUNDS DO I C@ >dig? DROP dig> I C! LOOP
hi BASE ! 0. 2SWAP >NUMBER 2DROP DECIMAL ;

: next-line ( -- c-addr u ) REFILL 0= IF QUIT ENDIF BL WORD COUNT ;
: .. ( d case -- ) benching IF 3DROP EXIT ENDIF CR ." Case #" 1 .R ." : " 1 UD.R ;
: AYB ( -- )
TIMER-RESET
next-line EVALUATE 0 ?DO next-line eval I 1+ .. wipe LOOP
CR .ELAPSED ;

:ABOUT CR ." Try AYB -- followed by the input" ;

0 [IF] ( 120/1 ms w/o output )

AYB
100
11001001
cats
zig
howareyou
gentlemen
allyour
baseare
belongto
us
hahaha
102345678
111111111
z abcdefghi
tbto4ot
tcu
p59pp5i5a
45iui6i1f
opppaapoa
i2jv7
mggi2i2gn
1xxf3ppxa
wbv9b9bjp
ggydgy
8585885gg
wllwliw4l
vzyvzon2y
x1xfldrdl
drtpzco
i5xfx
qdjj3ajaj
3333
sgkaaggsg
osjoojjjo
sam
ytytswyvs
k11dgzz4
p9bbb
hnhnn11n1
33bb33333
g636nxgbn
1v4gj5
bvbb5bb7b
mnmnmmmmn
0bzqozzop
guuugg
6oo2kk3yj
igsb7rirb
g7e30e0g0
vr0b2
u nil4n45n4
8rhdd
nnhuunv2h
fzfxnyfx
ddcvvcvvd
0170cc0yk
frr
00unxwjsk
ffuuhf44f
d4dcc4kcz
7j66j6676
rri2
1js11jm1s
8grqgq68m
0hsjv1ggg
d us7ytusfy
csnnsc
7 u52
d05d5d05d
ptmp
x0g
yveesyvvy
izvvitvtz
127j5s9m
txx2t22x2
jkykjkyjy
22yy2
l xymymxxex
t88r5dt0k
8sxx6400o
iiixp
mk
bbo22b2bo
i3ffbvffb
mloz5z
39wmzvj
xbvxy9yyx
9oc2g24o
mmtytomtt
e sus
p2c
aae0qbveq
maqm02qoo
coefo1ojc
cz

[ELSE] ( 120/1 ms w/o output )

AYB
100
11001001
cats
zig
howareyou
gentlemen
allyour
baseare
belongto
us
hahaha
102345678
111111111
z abcdefghi
1023456789
abcdefghijklmno
pqrstuvwxyz
nowiknowmyabcs
nexttimewontyou
singwithme
wealsowouldhave
acceptednexttime
wontyouplaywithme
theleftmostdigit
isaonethenyoucount
upfromthere
donotforgetthatthe
resultscangetvery
bigsobecareful
goreadthelarge
inputforyearof
codejaminthefinal
fromlastyear
butremember
thecakeisalie
bbabbbbaaaaababbabbababbaabbbabaabbbabbaabaaaaaaaaaaaaaaaaaa
cabcccbcccbacbabbbaacabacaccacbcacaaab
dbdcaacdbccdadccbdbcbaaaaaaaaa
dbdecadeaaaaaaaaaaaaaaaaaa
bbdddaccccfdfffdaedcfdee
bfdfaeedagfeeddaaebfdb
gheafffdbgehdbaaaaaa
gfifidhbeagdgicfcab
baaaaaaaaaaaaaaaaaa
bkiedeikkebaigaieb
fekkehkdfheehdife
bggmimkaekmaahfgb
gfnmibedgfmjmgii
cedmfconbinibegk
noalgldkhgeaaaa
fpqghedfkemkkgp
cmahnhaeppialnk
beophokododmjpb
mecqfaaaaaaaaa
01234456789012345
abcdefghijklmno
soh4zzb
guu
5ccpp5acaiaipa
mnti3i3kik3
66
i4777
7gg2sg2sn
8x8x8xx8xece8cxx
44aaaaa4qqaqsqa4
0k00hh
33338c8y939
1444lmkskl1
0uuu0uu0uxxx0uxux0u0
zsssg
ii5di
jjj5d0j990
ueu
sgk9aggsgss
a8tauu80ttuu
d69h9
hwenwwnjw
ndd0
88
hnhnn11n11
rjjrrrrrjr
7oeq7e7
881j1i
20v4vv24bb7
hgghvhhgwwvh
pijjjth
kj7
o326223ov6
psq12z2q2
ccbwcwwwwbwwwwbbcbbb
eiedjj1ddev
ejegstggwed
ff9f
nnhuunv2h2h4
k333k3k3
uumuumummmmumummmmuu
ag7pa
y 8uonnff
aaa66a6a6aa66aaaaaaaa6aa666a6aa

[THEN]

.ABOUT -all-your-base CR
DEPRIVE

(* End of Source *)

DOC
(* http://www.webcom.com/nazgul/change.html#gcc

For the curious, here are the results computed for various amounts, using coins in
denominations 1, 5, 10, 25 and 50. The ``answer'' column shows the number of ways
found to make change for the given amount, the ``leaves'' column shows the number
of leaf nodes in the tree recursion, and the ``calls'' column shows the total number
of times the recursive procedure was called.

(amount=)
n answer leaves calls
---------------------------------------------
50 50 786 1571
100 292 7750 15499
150 972 35888 71775
200 2435 114795 229589
250 5126 293666 587331
300 9590 646296 1292591
350 16472 1276080 2552159
400 26517 2321013 4642025
450 40570 3958690 7917379
500 59576 6411306 12822611
550 84580 9950656 19901311
600 116727 14903135 29806269
650 157262 21654738 43309475
700 207530 30656060 61312119
750 268976 42427296 84854591
800 343145 57563241 115126481
850 431682 76738290 153476579
900 536332 100711438 201422875
950 658940 130331280 260662559

All timings (argument = 200) are in seconds on a 75 MHz Pentium running Linux 1.2.13
with libc 5.0.9, except that CMUCL needed Linux 2.0.25 and libc 5.2.18, and MSW Logo
was run under Windows 95.

gcc Gnu C 0.05
p2c P2C Pascal Translator 0.05
a60 Algol 60 to C Translator 0.08
cmucl CMU Common Lisp 0.09
gcl Gnu Common Lisp 0.09
scheme MIT Scheme 0.15
swn MIT Scheme without Numerics 1.17
scheme48 Scheme 48 3.65
p4 P4 Pascal P-code Interpreter 7.31
postscript Ghostscript 8.52
emacs Emacs Lisp 12.27
awk Gnu Awk 15.34
orth Orthogonal 32.48
tex TeX 46.49
a60 Algol 60 Interpreter 69.69
intercal INTERCAL 75.60
ucblogo UCB Logo 214.00
mswlogo MSW Logo 221.00
logopascal Pascal in Logo 1049.00
walk Lisp in Awk 43000.00

*)
ENDDOC

ANEW -count_change

#1500 =: MAXSIZE

CREATE _cc1 1 , HERE MAXSIZE CELLS ALLOT MAXSIZE CELLS ERASE
CREATE _cc2 2 , HERE MAXSIZE CELLS ALLOT MAXSIZE CELLS ERASE
CREATE _cc3 3 , HERE MAXSIZE CELLS ALLOT MAXSIZE CELLS ERASE
CREATE _cc4 4 , HERE MAXSIZE CELLS ALLOT MAXSIZE CELLS ERASE
CREATE _cc5 5 , HERE MAXSIZE CELLS ALLOT MAXSIZE CELLS ERASE

CREATE _ccx 0 , _cc1 , _cc2 , _cc3 , _cc4 , _cc5 ,

: 'cc _ccx []CELL @ []CELL ; ( amount kinds_of_coins -- addr )

CREATE KOC 0 , 1 , 5 , #10 , #25 , #50 ,

: first_denomination KOC []CELL @ ; ( kinds_of_coins -- n )

\ The order of recursive calls is important!
\ Stack overflow will follow if they are interchanged.
: cc ( amount kinds_of_coins -- n )
OVER 0= IF 2DROP 1 EXIT ENDIF
OVER 0< IF 2DROP 0 EXIT ENDIF
DUP 0= IF 2DROP 0 EXIT ENDIF
2DUP 'cc DUP @ ?DUP IF >R 3DROP R> EXIT ENDIF
>R
2DUP DUP >R first_denomination - R> RECURSE >R
1- RECURSE
R> +
DUP R> ! ;

: count_change ( amount -- u )
DUP MAXSIZE >= ABORT" out of range"
CR TIMER-RESET
5 cc . .ELAPSED ;

: count_changes ( -- )
#1550 #50 DO CR I 5 .R TIMER-RESET
I 5 cc 9 .R 2 SPACES .ELAPSED
#50 +LOOP ;

CR .( Try: count_changes)

DOC
(*
\ P54C-166 iForth 1.11e
FORTH> count_changes
50 50 0.000 seconds elapsed.
100 292 0.000 seconds elapsed.
150 972 0.001 seconds elapsed.
200 2435 0.000 seconds elapsed.
250 5126 0.000 seconds elapsed.
300 9590 0.001 seconds elapsed.
350 16472 0.000 seconds elapsed.
400 26517 0.000 seconds elapsed.
450 40570 0.001 seconds elapsed.
500 59576 0.000 seconds elapsed.
550 84580 0.000 seconds elapsed.
600 116727 0.001 seconds elapsed.
650 157262 0.000 seconds elapsed.
700 207530 0.000 seconds elapsed.
750 268976 0.001 seconds elapsed.
800 343145 0.001 seconds elapsed.
850 431682 0.000 seconds elapsed.
900 536332 0.001 seconds elapsed.
950 658940 0.000 seconds elapsed.
1000 801451 0.000 seconds elapsed.
1050 965910 0.001 seconds elapsed.
1100 1154462 0.001 seconds elapsed.
1150 1369352 0.000 seconds elapsed.
1200 1612925 0.001 seconds elapsed.
1250 1887626 0.001 seconds elapsed.
1300 2196000 0.000 seconds elapsed.
1350 2540692 0.000 seconds elapsed.
1400 2924447 0.001 seconds elapsed.
1450 3350110 0.001 seconds elapsed.
1500 3820626 0.000 seconds elapsed. ok
*)
ENDDOC

\ EOF

(*
* LANGUAGE : ANS Forth
* PROJECT : Forth Environments
* DESCRIPTION : Eliza is a psychiatrist of the Carl Roger school.
* CATEGORY : AI Game, text based, by Weizenbaum.
* AUTHOR : Marcel Hendrix, November 11, 1986
* LAST CHANGE : July 24, 1993, Marcel Hendrix, case problem my$ My$
* LAST CHANGE : March 20, 1992, Marcel Hendrix, new TO strings
* LAST CHANGE : March 15, 1992, Marcel Hendrix
*)

NEEDS -miscutil
NEEDS -terminal
NEEDS -strings

REVISION -eliza "--- The Psychiater Version 1.21 ---"

PRIVATES

3 =: #Resp PRIVATE
#17 =: #Conjupairs PRIVATE
0 VALUE last-c PRIVATE
0 VALUE char# PRIVATE
0 VALUE phrase_voc PRIVATE

DEFER ECHO PRIVATE

: Rmargin C/L #10 - ; PRIVATE

WARNING @ WARNING OFF

: CR CR CLEAR char# ; PRIVATE

: SPACE char# IF SPACE 1 +TO char#
ENDIF ; PRIVATE

WARNING !

: EMIT' char# 1+ Rmargin > OVER BL = AND \ <char> --- <>
IF CR DROP
ELSE DUP TO last-c EMIT 1 +TO char#
ENDIF ; PRIVATE

: PRINT-? last-c '?' <> last-c '!' <> AND \ <> --- <>
IF '.' EMIT' ENDIF ; PRIVATE

: `TYPE' ABS #255 MIN \ <addr> <u> --- <>
0 ?DO
C@+
DUP '*' <> IF EMIT' \ This is all..
ELSE DROP -1 +TO char#
ECHO \ More (forward)
ENDIF
LOOP DROP ; PRIVATE

-- print a CR or BL, then the string

: .STRING DUP char# + Rmargin > \ <addr> <cnt> --- <>
IF CR
ELSE SPACE
ENDIF `TYPE' ; PRIVATE

S" Please do not repeat yourself." $CONSTANT Notrepeat$ PRIVATE
S" Goodbye" $CONSTANT Goodbye$ PRIVATE
S" Ok, hope to see you again." $CONSTANT Farewell$ PRIVATE
S" Hello..." $CONSTANT Hello$ PRIVATE
S" The doctor is in..please stand by." $CONSTANT Doctorin$ PRIVATE
S" Welcome in my shrinker's office." $CONSTANT Session$ PRIVATE

S" are you" $CONSTANT Areyou$ PRIVATE
S" are_you" $CONSTANT Are_you$ PRIVATE
S" you are" $CONSTANT Youare$ PRIVATE
S" you_are" $CONSTANT You_are$ PRIVATE
S" am I" $CONSTANT AmI$ PRIVATE
S" am_I" $CONSTANT Am_I$ PRIVATE
S" I am" $CONSTANT Iam$ PRIVATE
S" I_am" $CONSTANT I_am$ PRIVATE
S" YOU" $CONSTANT YOU$ PRIVATE
S" my" $CONSTANT myl$ PRIVATE
S" My" $CONSTANT Myu$ PRIVATE

-- Read ahead in text file. This doesn't work with a terminal.
-- A nice feature: the read text is interpreted, so { 1 2 + } works!

: READ-INFILE REFILL 0= ABORT" REFILL: Sorry"
TIB #TIB @ EVALUATE ; PRIVATE

-- Now read n strings ( 1 per line) from THIS file into a string array.

: READ-$ARRAY LOCAL arr \ <n> <$mid> --- <>
0 ?DO
READ-INFILE TO I (( arr )) DO$ARRAY
LOOP
REFILL 0= ABORT" REFILL: Sorry" ; PRIVATE

-- Read n strings ( 2 per line) from THIS file into a string array.

: 2READ-$ARRAY LOCAL arr \ <n> <$mid> --- <>
0 ?DO
READ-INFILE \ <> --- <a1> <u1> <a2> <u2>
TO I 1+ (( arr )) DO$ARRAY
TO I (( arr )) DO$ARRAY
2 +LOOP
REFILL 0= ABORT" REFILL: Sorry" ; PRIVATE

8 $ARRAY random_replies PRIVATE #40 NEW$ARRAY random_replies

8 $MID random_replies READ-$ARRAY
S" What does that suggest to you?"
S" Please elaborate on that"
S" I'm not sure I understand that fully"
S" Why?"
S" That's very interesting"
S" Well....please continue....."
S" And then?"
S" I see..Please tell me more about that"

STRING temp PRIVATE #255 NEW temp
STRING temp2 PRIVATE #255 NEW temp2
STRING temp3 PRIVATE #255 NEW temp3
STRING old PRIVATE #255 NEW old
STRING keep PRIVATE #255 NEW keep
STRING work PRIVATE #255 NEW work

#99 =: PUSH! PRIVATE
#66 =: PICK! PRIVATE
#33 =: EMPTY? PRIVATE
#24 =: /lines PRIVATE
#256 =: /chars PRIVATE

: STACK CREATE HERE >S 0 , ( addr) 0 , ( sp) \ <lines> <size> --- <>
* DUP ALLOCATE ?ALLOCATE
DUP S> !
SWAP ERASE
FORGET> @ FREE ?ALLOCATE
DOES> DUP @ LOCAL $stack
CELL+ LOCAL $sp
CASE
PUSH! OF $stack $sp @ /chars * + \ <c-addr> <u> --- <>
PACK DROP
$sp @ 1+ /lines MOD $sp !
ENDOF
PICK! OF $stack $sp @ CHOOSE \ <> --- <c-addr> <u>
/chars * + COUNT
ENDOF
EMPTY? OF $sp @ 1 U< \ <> --- <f>
ENDOF
ENDCASE ; PRIVATE

/lines /chars STACK CMDS PRIVATE

: OPENING-MESSAGE
CLS
#20 #10 AT-XY Doctorin$ .STRING
#1000 MS CLS
#20 #10 AT-XY Session$ .STRING
#00 #13 AT-XY Hello$ .STRING ; PRIVATE

: INPUT BEGIN
CR C/L 2- 0 DO 'Ä' EMIT LOOP
CR ." $ " $ID temp #255 $INPUT
SIZEOF temp 0= IF QUIT ENDIF \ Empty string
temp keep $= \ the same as before!
WHILE
CR Notrepeat$ .STRING
REPEAT
temp TO keep
'.' RTRIM temp '?' RTRIM temp temp TO old
Goodbye$ INDEX temp -1 <> IF CR Farewell$ .STRING
CR QUIT
ENDIF ; PRIVATE

#Conjupairs 2* $ARRAY conjugations PRIVATE 8 NEW$ARRAY conjugations

#Conjupairs 2* $MID conjugations 2READ-$ARRAY
S" are" S" am"
S" am" S" are"
S" you" S" me"
S" my" S" your"
S" your" S" my"
S" was" S" were"
S" mine" S" yours"
S" you" S" I"
S" I" S" you"
S" I've" S" you've"
S" you've" S" I've"
S" you are" S" I_am"
S" are you" S" am_I"
S" I am" S" you_are"
S" am I" S" are_you"
S" myself" S" yourself"
S" yourself" S" myself"

7 $ARRAY earlier_remarks PRIVATE #60 NEW$ARRAY earlier_remarks

7 $MID earlier_remarks READ-$ARRAY
S" Please tell me more about your*"
S" Is there a link here with your*?"
S" Does that have anything to do with your*?"
S" Why don't we go back and discuss your* a little more?"
S" Does any connection between that and your* suggest itself?"
S" Would you prefer to talk about your*"
S" I think perhaps worries about your* are bothering you"

: USE-EARLY-REMARKS
CR EMPTY? CMDS IF 8 CHOOSE random_replies .STRING
EXIT
ENDIF
7 CHOOSE earlier_remarks
0 ?DO C@+ DUP '*'
<> IF EMIT'
ELSE DROP PICK! CMDS .STRING
ENDIF
LOOP DROP ; PRIVATE

-- Take first blank-delimited word of userinput, the rest if no delimiter
-- found.

: NEXT-WORD BL SPLIT old \ <> --- <c-addr> <u>
IF DROP 2SWAP TO temp TO old
temp
ELSE old 0 0 TO old
ENDIF ; PRIVATE

: CONJUGATED #Conjupairs 2* \ <addr><u> -- <adr><u>
0 ?DO
2DUP I conjugations COMPARE
0= IF 2DROP
I 1+ conjugations
LEAVE
ENDIF
2 +LOOP ; PRIVATE

: .CONJUGATED CONJUGATED .STRING ; PRIVATE \ <c-addr> <u> --- <>

-- alternative trigger: ``my'' or ``My''

: "MY"-INPUT? myl$ INDEX old
DUP -1 <> IF 3 + #255 MID old PUSH! CMDS EXIT ENDIF DROP
Myu$ INDEX old
DUP -1 <> IF 3 + #255 MID old PUSH! CMDS EXIT ENDIF DROP ;
PRIVATE

: echo.it Areyou$ Are_you$ REPLACE old \ <> --- <>
Youare$ You_are$ REPLACE old
AmI$ Am_I$ REPLACE old
Iam$ I_am$ REPLACE old
BEGIN
NEXT-WORD DUP
WHILE
.CONJUGATED
REPEAT 2DROP ; PRIVATE

' echo.it IS ECHO

-- LOOKUP searches in PHRASE only.

: LOOKUP \ <c-addr> <u> --- <token> <true> | <false>
phrase_voc SEARCH-WORDLIST ; PRIVATE

: get$ >S \ <n> --- <c-addr> <u>
NEXT-WORD TO temp2 \ could be 0 string
S> 0 ?DO
S" _" +TO temp2
NEXT-WORD +TO temp2
LOOP
temp2 ; PRIVATE

: ?PHRASE FALSE \ <> --- <bool>
1 3 DO
old TO work
I get$
LOOKUP IF EXECUTE 0= LEAVE
ELSE work TO old
ENDIF
-1 +LOOP ; PRIVATE

: ?WORD FALSE >S old TO work \ <> --- <bool>
BEGIN
NEXT-WORD
DUP S 0= AND
WHILE
LOOKUP IF EXECUTE S> INVERT >S
ENDIF
REPEAT 2DROP
S> DUP FALSE = IF work TO old
ENDIF ; PRIVATE

(*
* LANGUAGE : ANS Forth
* PROJECT : Forth Environments
* DESCRIPTION : Sudoku solver
* CATEGORY : Game
* AUTHOR : Marcel Hendrix
* LAST CHANGE : Tuesday, May 05, 2020, 15:35, mhx;
*)

NEEDS -miscutil

REVISION -sudoku "--- Sudoku solver Version 1.00 ---"

PRIVATES

DOC
(*
CONTEST
-------
Go contest: https://codegolf.stackexchange.com/questions/190727/the-fastest-sudoku-solver

DATA STRUCTURE
--------------
Each of the Sudoku's 81 squares belongs to a unique tuple (line, column, box). We can identify
a line | column | box with 4 bits (1..9) , so 12 bits allow to label all squares.
Each of the 81 squares can hold 9 possible numbers, 1 or 2 or .. 9. This suggests
an array[81] of 32-bit entries:

bit: 40 .. 32 | 11 10 9 8 | 7 6 5 4 | 3 2 1 0
data: { d | l | c | b }

We have a list, or better a queue, of candidate entries to position on the board. When Sudoku
starts this is filled from the initial list of occupied squares. Unoccupied squares start out
as $F00xx, with the 12 'xx' bits set to the square's address.

Get the next candidate, place it (set its dth bit and bit 41 to mark it DONE),
then visit all squares that are on the same line or column, or in the same box.
These are entries that match either of the candidate's l, c, or b bits.
When we find such a square we know it CAN'T be occupied by the same number as our candidate,
so we reset the d-th bit in its d-field (decreasing the number of possible numbers there by 1).
If no d-bit is high, RETURN (either an error or recursion unsuccesful).

We will have 9 arrays of 9 square-addresses in the same row, 9 arrays of 9 column-addresses,
and 9 arrays of 9 box-addresses. Therefore, we are done after 27 tests. Dequeue the candidate.

Next we can run run through all d-fields looking for new candidates. These have a single bit
of their d-field set (none set => RETURN). Note that previous candidates are left alone because
they have bit 41 set. Copy these candidates to the queue and restart.

How do we know to stop? We should have 81 entries with bit 41 set and at most one other d-field bit.
What CAN happen is that the queue is empty nut there are a non-zero amount of entries that have
bit 41 unset. In this case we have to recurse / backtrack:
0. make a list of alternatives and point to the first #alternative
1. "push" 81-byte d-bits + #alternative
2. next alternative becomes candidate, call MYSELF
3. if !OK then
"pop" d-bits, inc #alternative, goto 1.
else "drop" d-bits
end
4. ...

We'll try it without backtracking first.

*)
ENDDOC

-- ---------------------
-- Variables
-- ---------------------

0 VALUE longtime PRIVATE
#1000 VALUE #do PRIVATE
0 VALUE #spaces PRIVATE

CREATE xbits PRIVATE #256 DUP * CELLS ALLOT xbits #256 DUP * CELLS CONST-DATA

: INIT-BITS #256 DUP * 0 DO I #bits I xbits []CELL ! LOOP ; INIT-BITS FORGET INIT-BITS

: COUNTBITS ( u -- n ) xbits []CELL @ ; PRIVATE

: rg 9 0 DO PARSE-NAME >FLOAT DROP F>S C, LOOP ; PRIVATE

CREATE grid0
rg 0 9 0 0 0 4 0 0 7
rg 0 0 0 0 0 7 9 0 0
rg 8 0 0 0 0 0 0 0 0

rg 4 0 5 8 0 0 0 0 0
rg 3 0 0 0 0 0 0 0 2
rg 0 0 0 0 0 9 7 0 6

rg 0 0 0 0 0 0 0 0 4
rg 0 0 3 5 0 0 0 0 0
rg 2 0 0 6 0 0 0 8 0
," originally 4.36 ms for the computer"

CREATE grid1
rg 0 0 6 0 5 0 0 0 0
rg 0 7 0 0 3 9 1 0 0
rg 0 8 0 0 0 0 0 3 0

rg 0 0 0 0 0 2 5 1 8
rg 0 0 0 0 0 0 0 0 0
rg 7 5 9 8 0 0 0 0 0

rg 0 6 0 0 0 0 0 7 0
rg 0 0 2 5 9 0 0 4 0
rg 0 0 0 0 6 0 3 0 0
," 45 minutes human"

CREATE grid2
rg 9 2 0 0 0 0 0 0 8
rg 0 8 0 0 0 0 0 5 1
rg 0 0 1 5 0 0 3 0 0

rg 0 0 0 9 0 7 8 0 0
rg 0 0 0 0 0 0 0 0 0
rg 0 0 3 6 0 2 0 0 0

rg 0 0 6 0 0 4 7 0 0
rg 5 7 0 0 0 0 0 8 0
rg 8 0 0 0 0 0 0 9 3
," 2 hours human"

CREATE grid3
rg 0 0 0 0 0 3 5 0 0
rg 0 0 0 7 0 0 4 0 0
rg 7 0 3 0 0 6 0 1 0

rg 0 1 0 0 0 5 0 0 6
rg 8 0 0 0 0 0 0 0 2
rg 4 0 0 3 0 0 0 8 0

rg 0 5 0 4 0 0 1 0 8
rg 0 0 8 0 0 9 0 0 0
rg 0 0 9 8 0 0 0 0 0
," 2 hours for a human, maybe impossible"

CREATE grid4
rg 2 0 0 0 3 0 7 0 6
rg 0 0 8 4 0 0 0 0 0
rg 6 0 0 0 9 0 0 3 0

rg 0 0 0 0 7 0 0 5 0
rg 8 0 9 3 0 5 1 0 2
rg 0 4 0 0 6 0 0 0 0

rg 0 6 0 0 2 0 0 0 8
rg 0 0 0 0 0 7 4 0 0
rg 3 0 2 0 5 0 0 0 9
," unknown source"

CREATE grid5
rg 9 0 0 0 1 0 6 0 0
rg 0 0 0 8 0 0 0 0 7
rg 6 3 0 0 0 7 2 0 0

rg 0 0 0 0 0 0 5 7 4
rg 0 0 0 2 4 3 0 0 0
rg 0 4 1 0 0 0 0 0 0

rg 0 0 9 6 0 4 8 3 1
rg 4 0 0 0 0 8 0 0 0
rg 0 0 8 0 2 0 0 0 9
," Paul Hsieh's example #1"

CREATE grid6
rg 0 0 9 6 0 0 1 0 0
rg 0 0 0 0 0 0 0 2 4
rg 6 0 0 0 0 2 0 9 0

rg 3 0 0 4 2 0 0 0 0
rg 0 8 0 3 1 0 0 0 7
rg 2 0 4 0 0 0 0 1 8

rg 0 0 0 7 0 4 8 0 2
rg 5 4 0 0 3 0 0 0 1
rg 7 9 0 5 0 0 0 0 0
," Paul Hsieh's example #2"

CREATE grid7
rg 0 5 0 0 0 8 6 0 0
rg 7 0 0 5 4 0 0 0 9
rg 0 1 0 0 6 0 0 0 3

rg 6 0 0 0 0 0 0 0 0
rg 0 3 0 0 0 0 0 8 0
rg 0 0 0 0 0 0 0 0 5

rg 9 0 0 0 3 0 0 1 0
rg 4 0 0 0 7 6 0 0 8
rg 0 0 1 8 0 0 0 7 0
," Paul Hsieh's example #3"

CREATE grid8
rg 0 9 8 0 0 0 0 0 0
rg 0 0 0 0 7 0 0 0 0
rg 0 0 0 0 1 5 0 0 0

rg 1 0 0 0 0 0 0 0 0
rg 0 0 0 2 0 0 0 0 9
rg 0 0 0 9 0 6 0 8 2

rg 0 0 0 0 0 0 0 3 0
rg 5 0 1 0 0 0 0 0 0
rg 0 0 0 4 0 0 0 2 0
," A `minimal' Sudoku (thought impossible for humans)"

CREATE grid9
rg 0 0 1 0 0 0 8 0 0
rg 0 7 0 3 1 0 0 9 0
rg 3 0 0 0 4 5 0 0 7

rg 0 9 0 7 0 0 5 0 0
rg 0 4 2 0 5 0 1 3 0
rg 0 0 3 0 0 9 0 4 0

rg 2 0 0 5 7 0 0 0 4
rg 0 3 0 0 9 1 0 6 0
rg 0 0 4 0 0 0 3 0 0
," Ertl #1"

CREATE grid10
rg 0 6 5 0 0 0 0 0 8
rg 7 0 0 8 6 0 4 0 0
rg 0 0 0 0 2 0 0 0 9

rg 0 4 0 0 0 1 0 0 2
rg 0 0 0 2 0 7 0 0 0
rg 3 0 0 5 0 0 0 7 0

rg 4 0 0 0 5 0 0 0 0
rg 0 0 1 0 7 9 0 0 3
rg 9 0 0 0 0 0 2 6 0
," Ertl #2"

CREATE grid11
rg 0 0 0 0 7 0 9 4 0
rg 0 0 0 0 9 0 0 0 5
rg 3 0 0 0 0 5 0 7 0

rg 0 0 7 4 0 0 1 0 0
rg 4 6 3 0 0 0 0 0 0
rg 0 0 0 0 0 7 0 8 0

rg 8 0 0 0 0 0 0 0 0
rg 7 0 0 0 0 0 0 2 8
rg 0 5 0 2 6 0 0 0 0
," Ertl #3"

CREATE grid12
rg 0 4 6 0 8 0 1 3 0
rg 3 9 0 5 0 6 2 0 7
rg 0 5 0 1 3 7 4 0 0

rg 0 0 0 0 9 1 7 0 0
rg 1 0 0 0 0 0 6 4 0
rg 0 0 0 8 0 0 9 0 2

rg 0 6 8 0 7 0 0 2 0
rg 0 0 5 0 0 3 8 7 0
rg 2 0 7 9 0 0 0 6 0
," Ertl #4"

CREATE grid13
rg 7 0 8 0 3 0 0 0 0
rg 0 9 0 0 2 7 0 0 0
rg 0 2 1 8 0 0 9 7 0

rg 0 0 0 0 0 4 5 8 0
rg 0 0 7 0 0 0 2 0 0
rg 0 5 6 7 0 0 0 0 0

rg 0 1 5 0 0 3 6 2 0
rg 0 0 0 2 6 0 0 3 0
rg 0 0 0 0 5 0 7 0 9
," Ertl #5"

CREATE grid14
rg 6 0 8 9 0 2 0 0 7
rg 0 0 0 0 7 0 9 0 0
rg 7 9 0 0 0 4 0 0 0

rg 5 0 0 0 0 7 3 0 0
rg 4 8 0 0 0 0 0 7 5
rg 0 0 7 6 0 0 0 0 4

rg 0 0 0 2 0 0 0 1 6
rg 0 0 1 0 3 0 0 0 0
rg 2 0 0 4 0 1 5 0 3
," Ertl #6"

CREATE grid15
rg 0 0 0 0 0 0 9 0 0
rg 1 7 0 0 0 5 0 0 2
rg 0 8 0 9 2 1 0 0 7

rg 0 1 0 0 9 0 5 0 0
rg 0 9 0 4 0 2 0 3 0
rg 0 0 4 0 7 0 0 2 0

rg 9 0 0 2 6 7 0 8 0
rg 6 0 0 8 0 0 0 7 1
rg 0 0 8 0 0 0 0 0 0
," Ertl #7"

CREATE grid16
rg 0 9 0 0 0 5 3 0 0
rg 0 0 0 0 2 0 8 0 5
rg 5 0 8 0 0 6 0 7 0

rg 0 0 1 4 0 0 0 0 0
rg 0 8 2 7 0 1 5 3 0
rg 0 0 0 0 0 3 6 0 0

rg 0 2 0 6 0 0 4 0 8
rg 4 0 9 0 3 0 0 0 0
rg 0 0 5 1 0 0 0 9 0
," Ertl #8"

CREATE grid17
rg 4 0 0 0 0 3 0 9 0
rg 0 9 0 2 0 5 3 1 0
rg 0 0 0 0 0 6 0 0 2

rg 0 3 1 7 0 0 9 0 0
rg 0 0 0 0 0 0 0 0 0
rg 0 0 5 0 0 1 8 6 0

rg 7 0 0 1 0 0 0 0 0
rg 0 8 3 6 0 4 0 2 0
rg 0 6 0 3 0 0 0 0 4
," Rickman ExtraHard"

: TRANSLATE ( char -- n )
>S
S" 0MAISFORTH" 0 DO C@+ S = IF S> 2DROP I UNLOOP EXIT ENDIF LOOP
S> 2DROP TRUE ABORT" Translate :: invalid character" ; PRIVATE

: xrg 9 0 DO PARSE-NAME DROP C@ TRANSLATE C, LOOP ; PRIVATE

(*
* LANGUAGE : ANS Forth
* PROJECT : Forth Environments
* DESCRIPTION : Sudoku solver
* CATEGORY : Game
* AUTHOR : Marcel Hendrix
* LAST CHANGE : Tuesday, May 05, 2020, 15:35, mhx;
*)

NEEDS -miscutil

REVISION -sudoku "--- Sudoku solver Version 1.00 ---"

PRIVATES

DOC
(*
CONTEST
-------
Go contest: https://codegolf.stackexchange.com/questions/190727/the-fastest-sudoku-solver

DATA STRUCTURE
--------------
Each of the Sudoku's 81 squares belongs to a unique tuple (line, column, box).
We can identify a line | column | box with 4 bits (1..9) , so 12 bits allow to
label all squares. Each of the 81 squares can hold 9 possible numbers, 1 or 2
or .. 9. This suggests an array[81] of 32-bit entries:

bit: 40 .. 32 | 11 10 9 8 | 7 6 5 4 | 3 2 1 0
data: { d | l | c | b }

We have a list, or better a queue, of candidate entries to position on the board.
When Sudoku starts this is filled from the initial list of occupied squares.
Unoccupied squares start out as $F00xx, with the 12 'xx' bits set to the
square's address.

Get the next candidate, place it (set its dth bit and bit 41 to mark it DONE),
then visit all squares that are on the same line or column, or in the same box.
These are entries that match either of the candidate's l, c, or b bits.
When we find such a square we know it CAN'T be occupied by the same number as
our candidate, so we reset the d-th bit in its d-field (decreasing the number
of possible numbers there by 1). If no d-bit is high, RETURN (either an error
or recursion unsuccesful).

We will have 9 arrays of 9 square-addresses in the same row, 9 arrays of 9
column-addresses, and 9 arrays of 9 box-addresses. Therefore, we are done
after 27 tests. Dequeue the candidate.

Next we can run run through all d-fields looking for new candidates. These
have a single bit of their d-field set (none set => RETURN). Note that previous
candidates are left alone because they have bit 41 set. Copy these candidates to
the queue and restart.

How do we know to stop? We should have 81 entries with bit 41 set and at most
one other d-field bit. What CAN happen is that the queue is empty nut there
are a non-zero amount of entries that have bit 41 unset. In this case we have
to recurse / backtrack:
0. make a list of alternatives and point to the first #alternative
1. "push" 81-byte d-bits + #alternative
2. next alternative becomes candidate, call MYSELF
3. if !OK then
"pop" d-bits, inc #alternative, goto 1.
else "drop" d-bits
end
4. ...

We'll try it without backtracking first.

*)
ENDDOC

-- ---------------------
-- Variables
-- ---------------------

0 VALUE longtime PRIVATE
#1000 VALUE #do PRIVATE
0 VALUE #spaces PRIVATE

CREATE xbits PRIVATE #256 DUP * CELLS ALLOT xbits #256 DUP * CELLS CONST-DATA

: INIT-BITS #256 DUP * 0 DO I #bits I xbits []CELL ! LOOP ; INIT-BITS FORGET INIT-BITS

: COUNTBITS ( u -- n ) xbits []CELL @ ; PRIVATE

: rg 9 0 DO PARSE-NAME >FLOAT DROP F>S C, LOOP ; PRIVATE

CREATE grid0
rg 0 9 0 0 0 4 0 0 7
rg 0 0 0 0 0 7 9 0 0
rg 8 0 0 0 0 0 0 0 0

rg 4 0 5 8 0 0 0 0 0
rg 3 0 0 0 0 0 0 0 2
rg 0 0 0 0 0 9 7 0 6

rg 0 0 0 0 0 0 0 0 4
rg 0 0 3 5 0 0 0 0 0
rg 2 0 0 6 0 0 0 8 0
," originally 4.36 ms for the computer"

CREATE grid1
rg 0 0 6 0 5 0 0 0 0
rg 0 7 0 0 3 9 1 0 0
rg 0 8 0 0 0 0 0 3 0

rg 0 0 0 0 0 2 5 1 8
rg 0 0 0 0 0 0 0 0 0
rg 7 5 9 8 0 0 0 0 0

rg 0 6 0 0 0 0 0 7 0
rg 0 0 2 5 9 0 0 4 0
rg 0 0 0 0 6 0 3 0 0
," 45 minutes human"

CREATE grid2
rg 9 2 0 0 0 0 0 0 8
rg 0 8 0 0 0 0 0 5 1
rg 0 0 1 5 0 0 3 0 0

rg 0 0 0 9 0 7 8 0 0
rg 0 0 0 0 0 0 0 0 0
rg 0 0 3 6 0 2 0 0 0

rg 0 0 6 0 0 4 7 0 0
rg 5 7 0 0 0 0 0 8 0
rg 8 0 0 0 0 0 0 9 3
," 2 hours human"

CREATE grid3
rg 0 0 0 0 0 3 5 0 0
rg 0 0 0 7 0 0 4 0 0
rg 7 0 3 0 0 6 0 1 0

rg 0 1 0 0 0 5 0 0 6
rg 8 0 0 0 0 0 0 0 2
rg 4 0 0 3 0 0 0 8 0

rg 0 5 0 4 0 0 1 0 8
rg 0 0 8 0 0 9 0 0 0
rg 0 0 9 8 0 0 0 0 0
," 2 hours for a human, maybe impossible"

CREATE grid4
rg 2 0 0 0 3 0 7 0 6
rg 0 0 8 4 0 0 0 0 0
rg 6 0 0 0 9 0 0 3 0

rg 0 0 0 0 7 0 0 5 0
rg 8 0 9 3 0 5 1 0 2
rg 0 4 0 0 6 0 0 0 0

rg 0 6 0 0 2 0 0 0 8
rg 0 0 0 0 0 7 4 0 0
rg 3 0 2 0 5 0 0 0 9
," unknown source"

CREATE grid5
rg 9 0 0 0 1 0 6 0 0
rg 0 0 0 8 0 0 0 0 7
rg 6 3 0 0 0 7 2 0 0

rg 0 0 0 0 0 0 5 7 4
rg 0 0 0 2 4 3 0 0 0
rg 0 4 1 0 0 0 0 0 0

rg 0 0 9 6 0 4 8 3 1
rg 4 0 0 0 0 8 0 0 0
rg 0 0 8 0 2 0 0 0 9
," Paul Hsieh's example #1"

CREATE grid6
rg 0 0 9 6 0 0 1 0 0
rg 0 0 0 0 0 0 0 2 4
rg 6 0 0 0 0 2 0 9 0

rg 3 0 0 4 2 0 0 0 0
rg 0 8 0 3 1 0 0 0 7
rg 2 0 4 0 0 0 0 1 8

rg 0 0 0 7 0 4 8 0 2
rg 5 4 0 0 3 0 0 0 1
rg 7 9 0 5 0 0 0 0 0
," Paul Hsieh's example #2"

CREATE grid7
rg 0 5 0 0 0 8 6 0 0
rg 7 0 0 5 4 0 0 0 9
rg 0 1 0 0 6 0 0 0 3

rg 6 0 0 0 0 0 0 0 0
rg 0 3 0 0 0 0 0 8 0
rg 0 0 0 0 0 0 0 0 5

rg 9 0 0 0 3 0 0 1 0
rg 4 0 0 0 7 6 0 0 8
rg 0 0 1 8 0 0 0 7 0
," Paul Hsieh's example #3"

CREATE grid8
rg 0 9 8 0 0 0 0 0 0
rg 0 0 0 0 7 0 0 0 0
rg 0 0 0 0 1 5 0 0 0

rg 1 0 0 0 0 0 0 0 0
rg 0 0 0 2 0 0 0 0 9
rg 0 0 0 9 0 6 0 8 2

rg 0 0 0 0 0 0 0 3 0
rg 5 0 1 0 0 0 0 0 0
rg 0 0 0 4 0 0 0 2 0
," A `minimal' Sudoku (thought impossible for humans)"

CREATE grid9
rg 0 0 1 0 0 0 8 0 0
rg 0 7 0 3 1 0 0 9 0
rg 3 0 0 0 4 5 0 0 7

rg 0 9 0 7 0 0 5 0 0
rg 0 4 2 0 5 0 1 3 0
rg 0 0 3 0 0 9 0 4 0

rg 2 0 0 5 7 0 0 0 4
rg 0 3 0 0 9 1 0 6 0
rg 0 0 4 0 0 0 3 0 0
," Ertl #1"

CREATE grid10
rg 0 6 5 0 0 0 0 0 8
rg 7 0 0 8 6 0 4 0 0
rg 0 0 0 0 2 0 0 0 9

rg 0 4 0 0 0 1 0 0 2
rg 0 0 0 2 0 7 0 0 0
rg 3 0 0 5 0 0 0 7 0

rg 4 0 0 0 5 0 0 0 0
rg 0 0 1 0 7 9 0 0 3
rg 9 0 0 0 0 0 2 6 0
," Ertl #2"

CREATE grid11
rg 0 0 0 0 7 0 9 4 0
rg 0 0 0 0 9 0 0 0 5
rg 3 0 0 0 0 5 0 7 0

rg 0 0 7 4 0 0 1 0 0
rg 4 6 3 0 0 0 0 0 0
rg 0 0 0 0 0 7 0 8 0

rg 8 0 0 0 0 0 0 0 0
rg 7 0 0 0 0 0 0 2 8
rg 0 5 0 2 6 0 0 0 0
," Ertl #3"

CREATE grid12
rg 0 4 6 0 8 0 1 3 0
rg 3 9 0 5 0 6 2 0 7
rg 0 5 0 1 3 7 4 0 0

rg 0 0 0 0 9 1 7 0 0
rg 1 0 0 0 0 0 6 4 0
rg 0 0 0 8 0 0 9 0 2

rg 0 6 8 0 7 0 0 2 0
rg 0 0 5 0 0 3 8 7 0
rg 2 0 7 9 0 0 0 6 0
," Ertl #4"

CREATE grid13
rg 7 0 8 0 3 0 0 0 0
rg 0 9 0 0 2 7 0 0 0
rg 0 2 1 8 0 0 9 7 0

rg 0 0 0 0 0 4 5 8 0
rg 0 0 7 0 0 0 2 0 0
rg 0 5 6 7 0 0 0 0 0

rg 0 1 5 0 0 3 6 2 0
rg 0 0 0 2 6 0 0 3 0
rg 0 0 0 0 5 0 7 0 9
," Ertl #5"

CREATE grid14
rg 6 0 8 9 0 2 0 0 7
rg 0 0 0 0 7 0 9 0 0
rg 7 9 0 0 0 4 0 0 0

rg 5 0 0 0 0 7 3 0 0
rg 4 8 0 0 0 0 0 7 5
rg 0 0 7 6 0 0 0 0 4

rg 0 0 0 2 0 0 0 1 6
rg 0 0 1 0 3 0 0 0 0
rg 2 0 0 4 0 1 5 0 3
," Ertl #6"

CREATE grid15
rg 0 0 0 0 0 0 9 0 0
rg 1 7 0 0 0 5 0 0 2
rg 0 8 0 9 2 1 0 0 7

rg 0 1 0 0 9 0 5 0 0
rg 0 9 0 4 0 2 0 3 0
rg 0 0 4 0 7 0 0 2 0

rg 9 0 0 2 6 7 0 8 0
rg 6 0 0 8 0 0 0 7 1
rg 0 0 8 0 0 0 0 0 0
," Ertl #7"

CREATE grid16
rg 0 9 0 0 0 5 3 0 0
rg 0 0 0 0 2 0 8 0 5
rg 5 0 8 0 0 6 0 7 0

rg 0 0 1 4 0 0 0 0 0
rg 0 8 2 7 0 1 5 3 0
rg 0 0 0 0 0 3 6 0 0

rg 0 2 0 6 0 0 4 0 8
rg 4 0 9 0 3 0 0 0 0
rg 0 0 5 1 0 0 0 9 0
," Ertl #8"

CREATE grid17
rg 4 0 0 0 0 3 0 9 0
rg 0 9 0 2 0 5 3 1 0
rg 0 0 0 0 0 6 0 0 2

rg 0 3 1 7 0 0 9 0 0
rg 0 0 0 0 0 0 0 0 0
rg 0 0 5 0 0 1 8 6 0

rg 7 0 0 1 0 0 0 0 0
rg 0 8 3 6 0 4 0 2 0
rg 0 6 0 3 0 0 0 0 4
," Rickman ExtraHard"

: TRANSLATE ( char -- n )
>S
S" 0MAISFORTH" 0 DO C@+ S = IF S> 2DROP I UNLOOP EXIT ENDIF LOOP
S> 2DROP TRUE ABORT" Translate :: invalid character" ; PRIVATE

On Monday, October 16, 2023 at 9:02:32 PM UTC+2, Marcel Hendrix wrote:
[..]
> * DESCRIPTION : Sudoku solver
[..]
Some examples:
FORTH> cd d:/dfwforth/examples/games
Directory: d:\dfwforth\examples\games ok
FORTH> in sudoku_fast
Creating --- Sudoku solver Version 1.00 ---
RTF ISO HMA
HMI ARF TOS
SOA TMH RIF
OAM RFT ISH
FRH SIM OAT
TIS HOA FRM
MSO FHR ATI
AFR MTI SHO
IHT OAS MFR
Grid in source valid.

0 9 0 | 0 0 4 | 0 0 7
0 0 0 | 0 0 7 | 9 0 0
8 0 0 | 0 0 0 | 0 0 0
------+-------+------
4 0 5 | 8 0 0 | 0 0 0
3 0 0 | 0 0 0 | 0 0 2
0 0 0 | 0 0 9 | 7 0 6
------+-------+------
0 0 0 | 0 0 0 | 0 0 4
0 0 3 | 5 0 0 | 0 0 0
2 0 0 | 6 0 0 | 0 8 0

========================== Sudoku ==============================gridX TO original -- choose grid X, where X = {0,1,..24}
godoit -- print, preliminary checks
solveit -- solve current grid
speedit -- test how fast current grid can be solved
speedthem -- test speed of all grids
( +n) reads -- read a 17-number sudoku from sudoku17.txt and time it (6361)
( start +n) readn -- read 17-number sudoku's between start and n (1 6362)
NGO -- read 49152 17-number sudoku's (GO contest, 6 minutes)
ok
FORTH> speedthem
0.032 milliseconds (originally 4.36 ms for the computer)
0.028 milliseconds (45 minutes human)
0.140 milliseconds (2 hours human)
0.030 milliseconds (2 hours for a human, maybe impossible)
0.003 milliseconds (unknown source)
0.005 milliseconds (Paul Hsieh's example #1)
0.004 milliseconds (Paul Hsieh's example #2)
0.004 milliseconds (Paul Hsieh's example #3)
0.303 milliseconds (A `minimal' Sudoku (thought impossible for humans))
0.005 milliseconds (Ertl #1)
0.014 milliseconds (Ertl #2)
0.433 milliseconds (Ertl #3)
0.002 milliseconds (Ertl #4)
0.004 milliseconds (Ertl #5)
0.015 milliseconds (Ertl #6)
0.003 milliseconds (Ertl #7)
0.009 milliseconds (Ertl #8)
0.005 milliseconds (Rickman ExtraHard)
0.029 milliseconds (Albert van der Horst's Python example)
113.000 milliseconds (Sudoku17.txt line 527)
347.000 milliseconds (Sudoku17.txt line 6361)
0.998 milliseconds (Arto Inkala, unsolvable to all but the sharpest minds)
5.344 milliseconds (David Filmer, rated above extreme)
16.000 milliseconds (W_a_x_man's challenge) ok

FORTH> NGO
==EOF=Most difficult Sudoku at line 44226 took 636 milliseconds.
Total time: 217.170 seconds. ok

-marcel