----------------------------------------------------------------------------------
@MSGID:
<d36f669b-d67d-42ff-8038-6e894c6f74e4n@googlegroups.com> 52b92ae8
@REPLY:
8f502b79
@REPLYADDR Ahmed MELAHI
<ahmed.melahi@univ-bejaia.dz>
@REPLYTO 2:5075/128 Ahmed MELAHI
@CHRS: CP866 2
@RFC: 1 0
@RFC-References:
@RFC-Message-ID:
<d36f669b-d67d-42ff-8038-6e894c6f74e4n@googlegroups.com>
@TZUTC: -0700
@PID: G2/1.0
@TID: FIDOGATE-5.12-ge4e8b94
Le jeudi 28 septembre 2023 ? 11:06:13 UTC, none albert a ?crit :
> 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
tri...@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 -
Hi,
Very interresting.
In CLP, it is known that the order of getting unkowns and also
the order of using constraints has an effect on the speed.
Here, I rewrote the word solve with the same order of getting
unkowns and using the same constraints as in the lisp program you have
provided.
\\ magic hexagon puzzle
19 values vA vB vC vD vE vF vG vH vI vJ vK vL vM vN vO vP vQ vR vS
1 to min val
19 to max val
: -- 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
;
: solve
begin
20 1 .-- --> vA vA ?,
20 1 .-- --> vB vB ?,
38 vA vB + - --- --> vC vC ?,
20 1 .-- --> vD vD ?,
38 vA vD + - --- --> vH vH ?,
20 1 .-- --> vE vE ?,
20 1 .-- --> vF vF ?,
38 vD vE vF + + - --- --> vG vG ?,
38 vC vG + - --- --> vL vL ?,
20 1 .-- --> vI vI ?,
38 vB vE vI + + - --- --> vM vM ?,
38 vH vM + - --- --> vQ vQ ?,
20 1 .-- --> vN vN ?,
38 vD vI vN + + - --- --> vR vR ?,
38 vQ vR + - --- --> vS vS ?,
38 vS vL + - --- --> vP vP ?,
38 vQ vN vC vF + + + - --- --> vJ vJ ?,
38 vA vE vJ vS + + + - --- --> vO vO ?,
38 vR vO vG + + - --- --> vK vK ?,
.mag hex vK | vO | vJ | vP | vS | vR | vN | vQ | vM | vI
| vL | vG | vF | vE | vH | vD | vC | vB | vA |
end
;
On my PC, with gforth, I found:
original forth program : about 263 ms
new forth program : about 353 ms
You should compare this last forth program with the lisp program.
Enjoy.
--- G2/1.0
* Origin: usenet.network (2:5075/128)
SEEN-BY: 5001/100 5005/49 5015/255 5019/40 5020/715
848 1042 4441 12000
SEEN-BY: 5030/49 1081 5058/104 5075/128
@PATH: 5075/128 5020/1042 4441