namespace unification starts working reasonable, buggs remain
[gule-log:guile-log.git] / logic / guile-log / guile-prolog / interpreter.scm
1 (define-module (logic guile-log guile-prolog interpreter)
2   #:use-module ((logic guile-log) #:select 
3                 (<clear> <define> <let> <let*> <=> <lookup> <match> <fail>
4                          <cut> <wrap> <state-ref> <state-set!> <continue>
5                          <code> <scm> <stall> <case-lambda>))
6   #:use-module (logic guile-log guile-prolog hash)
7   #:use-module (logic guile-log guile-prolog fluid)
8   #:use-module (logic guile-log vlist)
9   #:use-module (ice-9 match)
10   #:use-module (ice-9 readline)
11   #:use-module (ice-9 rdelim)
12   #:use-module (logic guile-log umatch)
13   #:use-module (logic guile-log iso-prolog)
14   #:use-module (logic guile-log prolog names)
15   #:use-module (logic guile-log prolog namespace)
16   #:use-module (logic guile-log prolog closed)
17   #:use-module (logic guile-log dynamic-features)
18   #:use-module (logic guile-log guile-prolog dynamic-features)
19
20   #:export (prolog-shell conversation leave read-prolog user_ref user_set 
21                          stall thin_stall))
22
23 (define -all- (make-fluid false))
24 (<wrap> add-fluid-dynamics -all-)
25
26 (define *user-data* (make-fluid vlist-null))
27 (<wrap> add-vhash-dynamics *user-data*)
28 (<define> (user_set a v)
29   (<code> (fluid-set! *user-data* (vhash-cons (<lookup> a)
30                                               (<scm> v)
31                                               (fluid-ref *user-data*)))))
32 (<define> (user_ret a v)
33   (<=> (_ . v) ,(vhash-assoc (<lookup> a) (fluid-ref *user-data*))))
34
35 (define (usr-ref x) 
36   (cdr (vhash-assoc x (fluid-ref *user-data*))))
37 (define (usr-set! x v) 
38   (fluid-set! *user-data* (vhash-cons x v (fluid-ref *user-data*))))
39
40 (define conversation1   #t)
41 (define conversation2   #t)
42 (define loop   #f)
43 (define finish #f)
44 (define leave  #f)
45 (define solve           #t)
46 (define output_and_more #t)
47 (define consult         #t)
48 (define conversation    #t)
49 (define conversation_   #t)
50 (define conversation__  #t)
51 (define more            #t)
52 (define write_out       #t)
53 (define empty           #t)
54 (define hash_new        #t)
55 (define vtosym          #t)
56 (mk-sym finish)
57
58 (define (prolog-shell)
59   ((@ (guile) catch) #t
60    (lambda () 
61      (<clear>)
62      (prolog-run 1 () (loop))
63      (format #t "leaving prolog~%"))
64    (lambda x
65      (format #t "System error~%~a~%RESTARTING~%" x)
66      (prolog-shell))))
67   
68 (define readline_term* (@ (logic guile-log guile-prolog readline)
69                           readline_term))
70 (define readline       (@ (logic guile-log guile-prolog readline)
71                           readline))
72 (define -n-            (@ (logic guile-log guile-prolog readline)
73                           -n-))
74
75 (define lold #f)
76 (define *usr-state* (make-fluid #f))
77 (define stall
78   (<case-lambda>
79    (()
80     (<code> 
81      (usr-set! 'stall-ret '())
82      (fluid-set! *usr-state* S)
83      (set! lold (<state-ref>))))
84
85    ((l)
86     (<code> 
87      (usr-set! 'stall-ret l)
88      (fluid-set! *usr-state* S)
89      (set! lold (<state-ref>))))
90    (<stall>)))
91
92 (<define> (thin_stall)
93   (<stall>))
94
95
96 (define *states* (make-hash-table))
97 (define (read-prolog port env)
98   (define all?  #f)
99   (define fail? #f)
100   (define mute? #f)
101   (define n?    #f)
102   (define help? #f)
103   (define save  #f)
104   (define load  #f)
105   (define cont  #f)
106   (define ref   #f)
107   (define set   #f)
108   (define old   #f)
109   (let* ((l 
110           (with-input-from-port port
111             (lambda ()
112               (let lp ((first? #t) (ch (peek-char)) (r '()) (dot-cont? #f))
113                 (when (eof-object? ch)
114                       (set! ch #\.))
115                 (match ch
116                   (#\space 
117                    (read-char)
118                    (if first? 
119                        (lp first? (peek-char) r           #f)
120                        (lp first? (peek-char) (cons ch r) #f)))
121                   
122                   (#\.
123                    (read-char)
124                    (if first?
125                        (let ((action ((@ (guile) read))))
126                          (cond 
127                           ((integer? action)
128                            (set! n? action))
129                           ((pair? action)
130                            action)
131                           (else
132                            (case action
133                              ((mute m) (set! mute? #t))
134                              ((all *)  (set! all?  #t))
135                              ((once)   (set! n?     1))
136                              ((h help) (set! help? #t))
137                              ((s save) (set! save  ((@ (guile) read))))
138                              ((l load) (set! load  ((@ (guile) read))))
139                              ((c cont) (set! cont  #t))
140                              ((ref)    (set! ref ((@ (guile) read))))
141                              ((set)    (set! set (list ((@ (guile) read))
142                                                        ((@ (guile) read)))))
143                              ((lo lold) 
144                               (set! old #t)
145                               (if lold (<state-set!> lold)))
146                              (else 
147                               (set! fail? #t)))
148
149                            (cond
150                             ((or fail? help?)
151                              #f)
152                             ((or load save cont ref set old)
153                              #t)
154                             (else
155                              (lp #t (peek-char) '() #f))))))
156                        (let ((ch (peek-char)))
157                          (if dot-cont?
158                              (lp #f ch (cons #\. r) #f)
159                              (if (eq? ch #\.)
160                                  (lp #f ch (cons #\. r) #t)
161                                  (list->string (reverse (cons #\. r))))))))
162
163                   (#\,
164                    (read-char)
165                    (if first?
166                        (cons ch (string->list (read-line)))
167                        (lp #f (peek-char) (cons ch r) #f)))
168                      
169                   (_
170                    (read-char)
171                    (lp #f (peek-char) (cons ch r) #f))))))))
172
173     (cond
174      (old
175       '((@ (guile) if)  #f #f))
176      (ref
177       `((@@ (logic guile-log guile-prolog interpreter) usr-ref) ,ref))
178
179      (set
180       `((@ (guile) begin)
181         ((@@ (logic guile-log guile-prolog interpreter) usr-set!) ,@set)
182         ((@ (guile) if)  #f #f)))
183
184      (load
185       `((@ (guile) begin)
186         ((@ (logic guile-log) <state-set!>) 
187          ((@ (guile) hash-ref) (@@ (logic guile-log guile-prolog interpreter)
188                                     *states*)
189            ',load))
190         ((@ (guile) if)  #f #f)))
191
192      (save
193       `((@ (guile) begin)
194          ((@ (guile) hash-set!) 
195           (@@ (logic guile-log guile-prolog interpreter) *states*)
196           ',save
197           ((@ (logic guile-log) <state-ref>)))
198          ((@ (guile) if)  #f #f)))
199
200      (cont
201       `((@ (logic guile-log) <continue>)))
202
203      (fail? 
204       '((@ (guile) begin)
205          ((@ (guile) format) #t "wrong-input of '.' action ~%")
206          ((@ (guile) if)  #f #f)))
207
208      (help?
209       (format #t "
210 HELP FOR PROLOG COMMANDS
211 ---------------------------------------------------------------------
212 (.n         )             try to find n solutions
213 (.all  | .* )             try to find all solutions
214 (.once | .1 )             try to find one solution
215 (.mute | .m )             no value output is written.
216 ---------------------------------------------------------------------
217 (.save | .s ) <ref>       associate current state with ref
218 (.load | .l ) <ref>       restore associate state with ref
219 (.cont | .c )             continue the execution from last stall point
220 (.lold | .lo)             restore the last state at a stall
221 ---------------------------------------------------------------------
222 (.ref       ) <ref>       get value of reference variable ref
223 (.set       ) <ref> <val> set user variable ref to value val
224 ---------------------------------------------------------------------
225
226 ")
227       '(if #f #f))
228         
229       
230      ((string? l)
231       (let ((str l))
232         (when (eq? (string-ref str 0) #\,)
233           (string-set! str 0 #\space)
234           (set! str (string-append str " "))
235           (with-input-from-string (string-trim str)
236             (lambda ()
237               ((@@ (system repl command) meta-command) repl)))
238           (set! str "do[#f]"))
239         `(let ()
240            ((@ (logic guile-log) <clear>))
241            ((@@ (logic guile-log iso-prolog) prolog-run) 1 ()
242             ((@@ (logic guile-log guile-prolog interpreter) 
243                  conversation1)                 
244              ,str 
245              ,((@ (guile) cond)
246                (all? '(@ (logic guile-log iso-prolog) true))
247                (n?   n?)
248                (else
249                 '(@ (logic guile-log iso-prolog) false)))
250              ,(if mute? 
251                   '(@ (logic guile-log iso-prolog) true)
252                   '(@ (logic guile-log iso-prolog) false))))
253            (if #f #f))))
254      (else
255       l))))
256
257 (<define> (readline_term T O)
258   (<let*> ((n  (fluid-ref -n-))
259            (pr (if (= n 1) "-? " (format #f "(~a)? " n)))
260            (cr (let lp ((n (string-length pr)))
261                  (if (= n 1)
262                      " "
263                      (string-append "." (lp (- n 1)))))))
264      (readline_term* pr cr T O)))
265
266 (define (readline_term_str s p cc Str T O)
267   (with-input-from-string Str
268     (lambda ()
269       (let ((port (current-input-port)))
270         (read_term s p cc port T O)))))
271           
272 (<define> (ftof X Y I H)
273    (<match> (#:mode +) (X Y)
274      (#(XL) #(YL) (<cut> (vtosym XL YL I H)))
275      (_     _     (<cut> <fail>))))
276
277 (define -nsol- (make-fluid false))
278 (<wrap> add-fluid-dynamics -nsol-)
279
280 (<define> (wrap_namespace x y yy)
281   (<let> ((x (<lookup> x)))
282     (<code> (gp-set! y (make-namespace 
283                         yy
284                         (namespace-ns      x)
285                         (namespace-local? x)
286                         (namespace-lexical? x))
287                      S))))
288
289 (compile-prolog-string
290 "
291 leave :- throw(leave).
292
293 loop :- catch(conversation,X,(write(X),nl,loop)).
294
295 conversation        :-
296   fluid_guard_dynamic_object(scm[-n-]),
297    (      
298       conversation__
299    ).
300
301 conversation__ :- 
302   do[(fluid-set! -n- (+ (fluid-ref -n-) 1))],
303   conversation_.
304
305 conversation_       :- 
306    (
307     fluid_guard_dynamic_object(scm[-all-]),
308     do[ (fluid-set! -all- false) ],
309     nl,readline_term(T,[variables(V),variable_names(N)]),
310     consult(T,V,N,false,false)     
311    ) ; conversation_.
312
313 conversation1(X,All,Mute) :- 
314   fluid_guard_dynamic_object(scm[-n-], scm[-nsol-], scm[-all-]),
315   state_guard_dynamic_object(scm[-n-], scm[-nsol-], scm[-all-], 
316                              scm[*user-data*]),
317   conversation2(X,All,Mute).
318
319 conversation2(X,All,Mute) :- 
320    do[(fluid-set! -n- (+ (fluid-ref -n-) 1))],
321    readline_term_str(X,T,[variables(V),variable_names(N)]),
322    consult(T,V,N,All,Mute).
323
324 consult(X,V,N,All,Mute)     :-
325    do[(fluid-set! -nsol- (<lookup> All))],
326    catch(((solve(X),output_and_more(Mute,V,N)) ; (nl,write(no),nl,fail)),
327         finish,
328         fail).
329
330 vtosym(X,Y) :- make_vhash(H),make_fluid(0,I),vtosym(X,Y,H,I).
331
332 %vtosym(X,Y,_,_) :- write([1,X,Y]),nl,fail.
333
334 vtosym(X,Y,H,I) :-
335   var(X)         -> (!, (vhashq_ref(H,X,Y);hash_new(X,Y,H,I)));
336   namespace_p(X) -> (!, namespace_val(X,XX),
337                         vtosym(XX,YY,H,I),
338                         wrap_namespace(X,Y,YY)) ; fail.
339
340
341 vtosym([X|XL],[U|UL],H,I) :- 
342   !,vtosym(X,U,H,I), vtosym(XL,UL,H,I).
343
344 vtosym([],[],_,_) :- !.
345 vtosym(X,Y,_,_)   :- atomic(X) -> (!,X=Y) ; fail.
346
347 vtosym(F,G,H,I) :- ftof(F,G,H,I).
348
349 vtosym(X,X,_,_) :- !.
350
351 hash_new(X,Y,H,I) :-
352   Y = scm[(string->symbol (format #f \"X~a\" (fluid-ref (<lookup> I))))],
353   fluid_set(I,scm[(+ 1 (fluid-ref (<lookup> I)))]),
354   vhashq_cons(H,X,Y).
355
356 output_and_more(Mute,V,N) :-
357    Mute == true -> more ;
358    (
359      (V==[] -> write('yes') ; (once(vtosym(V,VV)),write_out(VV,N),nl)), more
360    ).
361
362 write_out([],[]).
363 write_out([V|Vs],[N|Ns]) 
364   :- nl,write('   '),write(N),write(' = '),write(V),
365      write_out(Vs,Ns).
366
367 more :- 
368   scm[(fluid-ref -all-)]  == true -> fail           ; 
369   (
370     N=scm[(fluid-ref -nsol-)], 
371     (
372       N == true   -> fail ;
373       integer(N)  -> (N > 1 -> (do[(fluid-set! -nsol- (- (<lookup> N) 1))], 
374                                 fail)
375                            ; throw(finish))          ;
376       readline('more (y/n/a) > ',Ans),
377       (
378         Ans == 'y' -> fail                               ;
379         Ans == 'n' -> throw(finish)                      ;
380         Ans == 'a' -> scm[(fluid-set! -all- true)]==1      ;
381         write(' wrong input'),nl,more
382       )
383     )
384   ).
385
386 empty :- peek_char(X),char_code(X,Code),Code==10->get_char(_);true.
387
388 solve(X) :- X.
389 ")