-
Notifications
You must be signed in to change notification settings - Fork 1
/
queens.fiv
144 lines (139 loc) · 3.24 KB
/
queens.fiv
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
QUEENS
!000001AD
\ DRIVING PROGRAM QUEENS
: QUEENS ( N -> )
cls
depth 1 <
abort"
To run this demo type 'N queens' where N is the number of queens
you wish to use. If you uncomment a line in place-queens you will
see the search for the solution."
INITIALIZE-ARRAYS
DUP #QUEENS !
1- PLACE-QUEEN
IF .BOARD ." SUCCESS"
ELSE cls ." NO SOLUTION FOR " #queens @ . ." QUEENS" clreol
endif ;
-*-
v
MAX-QUEENS
!00000053
\ QUEENS PROBLEM DATA STRUCTURES
\ ALLOW UP TO 50 QUEENS
50 CONSTANT MAX-QUEENS
-*-
>
#QUEENS
!0000003D
VARIABLE #QUEENS \ Number of queens in use on current run
-*-
>
COL
!0000007F
\ NOTE: The row number implicitly =s the queen sequence number
CREATE COL MAX-QUEENS ALLOT \ Flag whether col occupied
-*-
>
DIAG1
!00000046
CREATE DIAG1 MAX-QUEENS 1 shl ALLOT \ Flag whether diag1 occupied
-*-
>
DIAG2
!00000046
CREATE DIAG2 MAX-QUEENS 1 shl ALLOT \ Flag whether diag2 occupied
-*-
>
XBOARD
!00000028
CREATE XBOARD MAX-QUEENS DUP * ALLOT
-*-
>
INITIALIZE-ARRAYS
!000000BC
\ INITIALIZE DATA STRUCTURES
: INITIALIZE-ARRAYS ( -> )
COL MAX-QUEENS 0 FILL
DIAG1 MAX-QUEENS 0 FILL
DIAG2 MAX-QUEENS 0 FILL
XBOARD MAX-QUEENS DUP * 0 FILL ;
-*-
>
.BOARD
!00000183
\ DISPLAY CURRENT BOARD RESULTS
: .BOARD ( -> )
?STACK abort" Stack underflow"
0 0 gotoxy ." Solution for " #queens @ dup . 1 =
if ." queen!"
else ." queens!" endif
clreol cr
#QUEENS @ 0 DO ( Row loop ) CR
#QUEENS @ 0 DO ( Column loop )
J #QUEENS @ * I + XBOARD + C@
IF ." * " ELSE ." . " endif
LOOP
LOOP ;
-*-
>
DIAG1-ADDR
!0000009A
\ COMPUTE DIAGONAL POSITIONS & DETERMINE IF SPACE IS FREE
: DIAG1-ADDR ( ROW COL -> DIAG1.ADDR ) ( "\" Slanted )
SWAP - #QUEENS @ + DIAG1 + ;
-*-
>
DIAG2-ADDR
!00000051
: DIAG2-ADDR ( ROW COL -> DIAG2.ADDR ) ( "/" Slanted )
+ 1+ DIAG2 + ;
-*-
>
SPACE-FREE?
!00000093
: SPACE-FREE? ( ROW COL -> FREE-FLAG )
DUP COL + C@ 0= >R
stack ab|abab DIAG1-ADDR C@ 0= >R
DIAG2-ADDR C@ 0= R> AND R> AND ;
-*-
>
PLACE-PIECE
!000000D1
\ PLACE & REMOVE PIECE FROM BOARD
: PLACE-PIECE ( ROW COL -> )
1 OVER COL + C!
OVER #QUEENS @ * OVER + XBOARD + 1 SWAP C!
stack ab|abab DIAG1-ADDR 1 SWAP C! DIAG2-ADDR 1 SWAP C! ;
-*-
>
REMOVE-PIECE
!000000AF
: REMOVE-PIECE ( ROW COL -> )
0 OVER COL + C!
OVER #QUEENS @ * OVER + XBOARD + 0 SWAP C!
stack ab|abab DIAG1-ADDR 0 SWAP C! DIAG2-ADDR 0 SWAP C! ;
-*-
>
PLACE-QUEEN
!00000249
\ PLACE-QUEEN RECURSIVE PROCEDURE
: PLACE-QUEEN ( #QUEENS.LEFT -> SUCCESS-FLAG )
DUP 0< NOT IF ( non-zero queen # )
0 SWAP #QUEENS @ 0
DO ( Sequence thru cols )
DUP I SPACE-FREE?
IF DUP I PLACE-PIECE
\ .BOARD ( <- uncomment this line to see the solutions as they are found!)
DUP 1- place-queen
IF ( success ) SWAP DROP 1 SWAP LEAVE
ELSE ( failure ) DUP I REMOVE-PIECE endif
endif
LOOP DROP ( drop #queens leaving flag )
ELSE ( last queen ) DROP 1 endif ;
-*-
>
DEMO
!0000002D
: demo 1 10 do i queens key drop -1 +loop ;
-*-
^