XPost: comp.lang.lisp
Recently a solution was published on forth for the magic 38 hexagon.
It is portable, iso 94 with an environmental dependency for case-insensitivity. This makes it run on most any Forths.
It uses macro's to make the source more directly related to the problem.
This can be seen by immediate definitions that compile code using `POSTPONE.
\ -------------------8<------------------------------
\ Place the integers 1..19 in the following Magic Hexagon of rank 3
\ __A_B_C__
\ _D_E_F_G_
\ H_I_J_K_L
\ _M_N_O_P_
\ __Q_R_S__
\ so that the sum of all numbers in a straight line (horizontal and diagonal)
\ is equal to 38.
: values 0 ?do 0 value loop ;
19 values vA vB vC vD vE vF vG vH vI vJ vK vL vM vN vO vP vQ vR vS
create marking_table 77 allot
marking_table 77 1 fill
marking_table 38 + value marked
marked 20 erase
: -- 2 .r 2 spaces ;
: .mag_hex
cr
cr
4 spaces vA -- vB -- vC -- cr
2 spaces vD -- vE -- vF -- vG -- cr
vH -- vI -- vJ -- vK -- vL -- cr
2 spaces vM -- vN -- vO -- vP -- cr
4 spaces vQ -- vR -- vS --
cr
;
0 value nloops_prec
0 value nloops
0 value constraint_num
20 value max_num_constraints
create loop_loc max_num_constraints allot
loop_loc max_num_constraints erase
: mark 1 swap marked + c! ;
: unmark 0 swap marked + c! ;
: marked? marked + c@ 0= ;
: .-- nloops 1+ to nloops postpone do postpone i ; immediate
: ?, postpone dup postpone marked? postpone if postpone mark ; immediate
: --> postpone to constraint_num 1+ to constraint_num nloops nloops_prec <> if 1 loop_loc constraint_num + c! nloops to nloops_prec then ; immediate
: constraints_begin( marked 20 erase ;
: finish: nloops 0 do postpone unloop loop postpone exit ; immediate
\ : finish: postpone .mag_hex ; immediate
: --- ; immediate
: _begin_ marked 20 erase ;
: | postpone unmark postpone else postpone drop postpone then loop_loc constraint_num + c@ if postpone loop then constraint_num 1- to constraint_num ; immediate
: _end_ ; immediate
: solve
_begin_
20 1 .-- --> vA vA ?,
20 1 .-- --> vB vB ?,
38 vA vB + - --- --> vC vC ?,
20 1 .-- --> vG vG ?,
38 vC vG + - --- --> vL vL ?,
20 1 .-- --> vP vP ?,
38 vL vP + - --- --> vS vS ?,
20 1 .-- --> vR vR ?,
38 vS vR + - --- --> vQ vQ ?,
20 1 .-- --> vM vM ?,
38 vQ vM + - --- --> vH vH ?,
38 vA vH + - --- --> vD vD ?,
20 1 .-- --> vE vE ?,
38 vD vE + vG + - --- --> vF vF ?,
38 vB vF + vP + - --- --> vK vK ?,
38 vG vK + vR + - --- --> vO vO ?,
38 vP vO + vM + - --- --> vN vN ?,
38 vR vN + vD + - --- --> vI vI ?,
38 vH vI + vK + vL + - --- --> vJ vJ ?,
.mag_hex vJ | vI | vN | vO | vK | vF | vE | vD | vH | vM | vQ | vR | vS | vP | vL | vG | vC | vB | vA |
_end_
;
: main solve ;
\ -------------------8<------------------------------
Fast forths obtained the (first) solution in time under 1 mS.
I thought this was a typical lisp problem and indeed I found the following
lisp program, equally using macro's (using ` and , )
Straightened out a bit to not pass the 72 line limit.
; -------------------8<------------------------------
; (C) 2006 Markus Triska
triska@metalevel.at
; Public domain code.
; A B C
; D E F G
; H I J K L
; M N O P
; Q R S
; "l", the "loop" macro
(defmacro l (var code)
`(loop for ,var from 1 to 19 do
(when (not (aref used ,var))
(setf (aref used ,var) t)
,code
(setf (aref used ,var) nil))))
; "sc", the "set & check" macro, used when all other variables in the line
; are already assigned values
(defmacro sc (var others code)
`(let ((,var (- 38 ,@others)))
(when (and (<= 1 ,var) (<= ,var 19) (not (aref used ,var)))
(setf (aref used ,var) t)
,code
(setf (aref used ,var) nil))))
(defun solve ()
(let ((used (make-array 20)))
(l a
(l b
(sc c (a b)
(l d
(sc h (a d)
(l e
(l f
(sc g (d e f)
(sc l (c g)
(l i
(sc m (b e i)
(sc q (h m)
(l n
(sc r (d i n)
(sc s (q r)
(sc p (s l)
(sc j (q n c f)
(sc o (a e j s)
(sc k (r o g)
(print (list a b c d e f g h i j k l m n o p q r s)))))))))))))))))))))))
(solve)
(quit)
; -------------------8<------------------------------
The idea is much the same:
Loop over a for the full range
(l a
Loop for vA in the range [1,20) , mark vA as used up
20 1 .-- --> vA vA ?,
Loop over c , range restricted to 38-a-b
(sc c (a b)
Loop over c , range restriced to 38-a-b, mark vA as used up
38 vA vB + - --- --> vC vC ?,
To fairly compare the two programs, the Forth program must generate
all solutions. This is done by uncommenting the second definition
of finish.
The difference in run time are dramatic!
We compare sf (try out version of a commercial program Swiftforth )
to clisp.
~/PROJECT/magic: time time sf magicgoon.f
MARKED isn't unique.
finish: isn't unique.
finish: isn't unique.
3 17 18
19 7 1 11
16 2 5 6 9
12 4 8 14
10 13 15
...
real 0m0.055s
user 0m0.035s
sys 0m0.012s
~/PROJECT/magic: time clisp mhex1.lisp
(3 17 18 19 7 1 11 16 2 5 6 9 12 4 8 14 10 13 15)
...
real 0m8.415s
user 0m7.191s
sys 0m0.041s
Even if the lisp source is compiled, the difference is approximately
25 to 1.
~/PROJECT/magic: time clisp mhex1.fas
(3 17 18 19 7 1 11 16 2 5 6 9 12 4 8 14 10 13 15)
....
real 0m1.058s
user 0m0.855s
sys 0m0.018s
Groetjes Albert
--
Don't praise the day before the evening. One swallow doesn't make spring.
You must not say "hey" before you have crossed the bridge. Don't sell the
hide of the bear until you shot it. Better one bird in the hand than ten in
the air. First gain is a cat spinning. - the Wise from Antrim -
--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)