interpreter.scm 5.16 KB
Newer Older
1
(define-module (logic guile-log guile-prolog interpreter)
2 3 4 5 6
  #:use-module ((logic guile-log) #:select 
                (<clear> <define> <let> <let*> <=>))
  #:use-module (ice-9 match)
  #:use-module (ice-9 readline)
  #:use-module (ice-9 rdelim)
7 8 9 10 11
  #:use-module (logic guile-log umatch)
  #:use-module (logic guile-log iso-prolog)
  #:use-module (logic guile-log prolog names)
  #:use-module (logic guile-log dynamic-features)
  #:use-module (logic guile-log guile-prolog dynamic-features)
12 13

  #:export (prolog-shell conversation leave read-prolog))
14 15 16 17 18 19 20 21

(define p  (lambda x x))
(define cc (lambda x x))
(define s  (fluid-ref *current-stack*))

(define -all- (make-fluid false))
(add-fluid-dynamics s p cc -all-)

22 23 24
(define conversation1   #t)
(define conversation2   #t)
(define loop   #f)
25 26 27 28 29 30 31
(define finish #f)
(define leave  #f)
(define solve           #t)
(define output_and_more #t)
(define consult         #t)
(define conversation    #t)
(define conversation_   #t)
32
(define conversation__  #t)
33 34
(define more            #t)
(define write_out       #t)
35
(define empty           #t)
36 37 38

(mk-sym finish)

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
(define (prolog-shell)
  ((@ (guile) catch) #t
   (lambda () 
     (<clear>)
     (prolog-run 1 () (loop))
     (format #t "leaving prolog~%"))
   (lambda x
     (format #t "System error~%~a~%RESTARTING~%" x)
     (prolog-shell))))
  
(define readline_term* (@ (logic guile-log guile-prolog readline)
			  readline_term))
(define readline       (@ (logic guile-log guile-prolog readline)
			  readline))
(define -n-            (@ (logic guile-log guile-prolog readline)
		 	  -n-))

(define (read-prolog port env)
  (let* ((l 
	  (with-input-from-port port
	    (lambda ()
	      (let lp ((first? #t) (ch (peek-char)) (r '()))
		(when (eof-object? ch)
		      (set! ch #\.))
		(match ch		       
		  (#\space 
		   (read-char)
		   (if first? 
		       (lp first? (read-char) r)
		       (lp first? (read-char) (cons ch r))))
		  (#\,
		   (read-char)
		   (if first?
		       (cons ch (string->list (read-line)))
		       (lp #f (peek-char) (cons ch r))))

		  (#\[ 
		     (if first?
			 ((@ (guile) read))
			 (begin
			   (read-char)
			   (lp #f (peek-char) (cons ch r)))))
		     
		  (#\.
		   (read-char)
		   (list->string (reverse (cons #\. r))))

		  (_
		   (read-char)
		   (lp #f (peek-char) (cons ch r)))))))))

    (if (string? l)
	(let ((str l))
	  (add-history str)
	  (when (eq? (string-ref str 0) #\()
		(set! str (string-append "do[" str "]")))
	  (when (eq? (string-ref str 0) #\,)
		(string-set! str 0 #\space)
		(set! str (string-append str " "))
		(with-input-from-string (string-trim str)
		  (lambda ()
		    ((@@ (system repl command) meta-command) repl)))
		(set! str "do[#f]"))
	  `(let ((fr ((@ (logic guile-log umatch) gp-newframe) 
                      ((@ (guile) fluid-ref)
                       (@ (logic guile-log umatch) *current-stack*)))))
             ((@ (guile) dynamic-wind)
              ((@ (guile) lambda) () #f)
              ((@ (guile) lambda) () 
               ((@@ (logic guile-log iso-prolog) prolog-run) 1 () 
                ((@@ (logic guile-log guile-prolog interpreter) 
                     conversation1)
                 ,str)))
              ((@ (guile) lambda) () 
               ((@ (logic guile-log umatch) gp-unwind) fr)))
	     (if #f #f)))
	l)))

(<define> (readline_term T O)
  (<let*> ((n  (fluid-ref -n-))
	   (pr (if (= n 1) "-? " (format #f "(~a)? " n)))
	   (cr (let lp ((n (string-length pr)))
		 (if (= n 1)
		     " "
		     (string-append "." (lp (- n 1)))))))
     (readline_term* pr cr T O)))

(define (readline_term_str s p cc Str T O)
  (with-input-from-string Str
    (lambda ()
      (let ((S (current-input-port)))
        (read_term s p cc S T O)))))
	  
 
133 134
(compile-prolog-string
"
135 136 137
leave :- throw(leave).

loop :- catch(conversation,X,(write(X),nl,loop)).
138 139 140 141

conversation        :-
  with_fluid_guard_dynamic_object
   (
142 143
      scm[-n-], 
      conversation__
144 145
   ).

146 147 148
conversation__ :- 
  _=scm[(fluid-set! -n- (+ (fluid-ref -n-) 1))],
  conversation_.
149 150 151

conversation_       :- 
   (
152
    with_fluid_guard_dynamic_object
153 154 155
     (
        scm[-all-],
        ( 
156 157
            _ = scm[ (fluid-set! -all- false) ],
            nl,read_term(T,[variables(V),variable_names(N)]),
158 159 160 161 162
            consult(T,V,N)
        )
     )
   ) ; conversation_.

163 164 165 166 167 168 169 170 171 172 173 174
conversation1(X) :- 
  with_fluid_guard_dynamic_object
   (
      scm[-n-],
      conversation2(X)
   ).

conversation2(X) :- 
   _=scm[(fluid-set! -n- (+ (fluid-ref -n-) 1))],
   readline_term_str(X,T,[variables(V),variable_names(N)]),
   consult(T,V,N).

175
consult(X,V,N)     :-    
176
   catch(((solve(X),output_and_more(V,N)) ; (nl,write(no),nl,fail)),
177 178 179 180 181 182 183 184 185 186 187 188 189
        finish,
        fail).

output_and_more(V,N) :-
   (V==[] -> write('yes') ; write_out(V,N)),more.

write_out([],[]).
write_out([V|Vs],[N|Ns]) 
  :- nl,write('   '),write(N),write(' = '),write(V),
     write_out(Vs,Ns).

more :- 
  scm[(fluid-ref -all-)] == true -> fail           ; 
190 191 192 193 194 195 196 197 198
  nl,readline('more (y/n/a) > ',Ans),
  (
    Ans == 'y' -> fail                               ;
    Ans == 'n' -> throw(finish)                      ;
    Ans == 'a' -> scm[(fluid-set! -all- true)]==1      ;
    write(' wrong input'),more
  ).

empty :- peek_char(X),char_code(X,Code),Code==10->get_char(_);true.
199 200 201

solve(X) :- X.
")