1(**************************************************************************)
2(*                                                                        *)
3(*                                OCaml                                   *)
4(*                                                                        *)
5(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
6(*                                                                        *)
7(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
8(*     en Automatique.                                                    *)
9(*                                                                        *)
10(*   All rights reserved.  This file is distributed under the terms of    *)
11(*   the GNU Lesser General Public License version 2.1, with the          *)
12(*   special exception on linking described in the file LICENSE.          *)
13(*                                                                        *)
14(**************************************************************************)
15
16("d1": int 0 int 1
17 "d2": int 1 int 0
18 "d3": int 0 int -1
19 "d4": int -1 int 0
20 "dir": val "d1" val "d2" val "d3" val "d4")
21
22("counter": int 0)
23
24(* Out = 0  Empty = 1  Peg = 2 *)
25
26("line0": int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0
27 "line1": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
28 "line2": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
29 "line3": int 0 int 2 int 2 int 2 int 2 int 2 int 2 int 2 int 0
30 "line4": int 0 int 2 int 2 int 2 int 1 int 2 int 2 int 2 int 0
31 "line5": int 0 int 2 int 2 int 2 int 2 int 2 int 2 int 2 int 0
32 "line6": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
33 "line7": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0
34 "line8": int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0
35 "board": val "line0" val "line1" val "line2" val "line3"
36          val "line4" val "line5" val "line6" val "line7" val "line8")
37
38("format": string "%d\n\000")
39
40(function "solve" (m: int)
41  (store int "counter" (+ (load int "counter") 1))
42  (if (== m 31)
43      (== (intaref (addraref "board" 4) 4) 2)
44    (try
45     (if (== (mod (load int "counter") 500) 0)
46          (extcall "printf_int" "format" (load int "counter") unit)
47       [])
48     (let i 1
49       (while (<= i 7)
50         (let j 1
51           (while (<= j 7)
52             (if (== (intaref (addraref "board" i) j) 2)
53                 (seq
54                  (let k 0
55                    (while (<= k 3)
56                      (let (d1 (intaref (addraref "dir" k) 0)
57                            d2 (intaref (addraref "dir" k) 1)
58                            i1 (+ i d1)
59                            i2 (+ i1 d1)
60                            j1 (+ j d2)
61                            j2 (+ j1 d2))
62                        (if (== (intaref (addraref "board" i1) j1) 2)
63                            (if (== (intaref (addraref "board" i2) j2) 1)
64                                (seq
65                                 (intaset (addraref "board" i) j 1)
66                                 (intaset (addraref "board" i1) j1 1)
67                                 (intaset (addraref "board" i2) j2 2)
68                                 (if (app "solve" (+ m 1) int)
69                                     (raise_notrace 0a)
70                                   [])
71                                 (intaset (addraref "board" i) j 2)
72                                 (intaset (addraref "board" i1) j1 2)
73                                 (intaset (addraref "board" i2) j2 1))
74                              [])
75                          []))
76                      (assign k (+ k 1)))))
77               [])
78             (assign j (+ j 1))))
79         (assign i (+ i 1))))
80     0
81   with bucket
82     1)))
83
84("format_out": string ".\000")
85("format_empty": string " \000")
86("format_peg": string "$\000")
87("format_newline": string "\n\000")
88
89(function "print_board" ()
90  (let i 0
91    (while (< i 9)
92      (let j 0
93        (while (< j 9)
94          (switch 3 (intaref (addraref "board" i) j)
95            case 0:
96              (extcall "print_string" "format_out" unit)
97            case 1:
98              (extcall "print_string" "format_empty" unit)
99            case 2:
100              (extcall "print_string" "format_peg" unit))
101          (assign j (+ j 1))))
102      (extcall "print_string" "format_newline" unit)
103      (assign i (+ i 1)))))
104
105(function "solitaire" ()
106  (seq
107    (if (app "solve" 0 int)
108        (app "print_board" [] unit)
109      [])
110    0))
111