prolog: write/1 + nl/0 via output buffer, 7 tests; built-ins box done
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
This commit is contained in:
@@ -299,6 +299,8 @@
|
||||
((pl-cut? g) (begin (dict-set! cut-box :cut true) (k)))
|
||||
((and (pl-atom? g) (= (pl-atom-name g) "true")) (k))
|
||||
((and (pl-atom? g) (= (pl-atom-name g) "fail")) false)
|
||||
((and (pl-atom? g) (= (pl-atom-name g) "nl"))
|
||||
(begin (pl-output-write! "\n") (k)))
|
||||
((and (pl-compound? g) (= (pl-fun g) "=") (= (len (pl-args g)) 2))
|
||||
(pl-solve-eq! (first (pl-args g)) (nth (pl-args g) 1) trail k))
|
||||
((and (pl-compound? g) (= (pl-fun g) "\\=") (= (len (pl-args g)) 2))
|
||||
@@ -335,6 +337,10 @@
|
||||
(let
|
||||
((call-cb {:cut false}))
|
||||
(pl-solve! db (first (pl-args g)) trail call-cb k)))
|
||||
((and (pl-compound? g) (= (pl-fun g) "write") (= (len (pl-args g)) 1))
|
||||
(begin
|
||||
(pl-output-write! (pl-format-term (first (pl-args g))))
|
||||
(k)))
|
||||
(true (pl-solve-user! db g trail cut-box k))))))
|
||||
|
||||
(define
|
||||
@@ -387,6 +393,42 @@
|
||||
(pl-trail-undo-to! trail mark)
|
||||
(pl-solve! db else-goal trail cut-box k)))))))))
|
||||
|
||||
(define pl-output-buffer "")
|
||||
|
||||
(define pl-output-clear! (fn () (set! pl-output-buffer "")))
|
||||
|
||||
(define
|
||||
pl-output-write!
|
||||
(fn (s) (begin (set! pl-output-buffer (str pl-output-buffer s)) nil)))
|
||||
|
||||
(define
|
||||
pl-format-args
|
||||
(fn
|
||||
(args)
|
||||
(cond
|
||||
((empty? args) "")
|
||||
((= (len args) 1) (pl-format-term (first args)))
|
||||
(true
|
||||
(str
|
||||
(pl-format-term (first args))
|
||||
", "
|
||||
(pl-format-args (rest args)))))))
|
||||
|
||||
(define
|
||||
pl-format-term
|
||||
(fn
|
||||
(t)
|
||||
(let
|
||||
((w (pl-walk-deep t)))
|
||||
(cond
|
||||
((pl-var? w) (str "_" (pl-var-id w)))
|
||||
((pl-atom? w) (pl-atom-name w))
|
||||
((pl-num? w) (str (pl-num-val w)))
|
||||
((pl-str? w) (pl-str-val w))
|
||||
((pl-compound? w)
|
||||
(str (pl-fun w) "(" (pl-format-args (pl-args w)) ")"))
|
||||
(true (str w))))))
|
||||
|
||||
(define
|
||||
pl-solve-not-eq!
|
||||
(fn
|
||||
|
||||
@@ -421,4 +421,78 @@
|
||||
(pl-mk-trail))
|
||||
false)
|
||||
|
||||
(pl-s-test!
|
||||
"write(hello)"
|
||||
(begin
|
||||
(pl-output-clear!)
|
||||
(pl-solve-once!
|
||||
pl-s-empty-db
|
||||
(pl-s-goal "write(hello)" {})
|
||||
(pl-mk-trail))
|
||||
pl-output-buffer)
|
||||
"hello")
|
||||
|
||||
(pl-s-test!
|
||||
"nl outputs newline"
|
||||
(begin
|
||||
(pl-output-clear!)
|
||||
(pl-solve-once! pl-s-empty-db (pl-s-goal "nl" {}) (pl-mk-trail))
|
||||
pl-output-buffer)
|
||||
"\n")
|
||||
|
||||
(pl-s-test!
|
||||
"write(42) outputs digits"
|
||||
(begin
|
||||
(pl-output-clear!)
|
||||
(pl-solve-once!
|
||||
pl-s-empty-db
|
||||
(pl-s-goal "write(42)" {})
|
||||
(pl-mk-trail))
|
||||
pl-output-buffer)
|
||||
"42")
|
||||
|
||||
(pl-s-test!
|
||||
"write(foo(a, b)) formats compound"
|
||||
(begin
|
||||
(pl-output-clear!)
|
||||
(pl-solve-once!
|
||||
pl-s-empty-db
|
||||
(pl-s-goal "write(foo(a, b))" {})
|
||||
(pl-mk-trail))
|
||||
pl-output-buffer)
|
||||
"foo(a, b)")
|
||||
|
||||
(pl-s-test!
|
||||
"write conjunction"
|
||||
(begin
|
||||
(pl-output-clear!)
|
||||
(pl-solve-once!
|
||||
pl-s-empty-db
|
||||
(pl-s-goal "write(a), write(b)" {})
|
||||
(pl-mk-trail))
|
||||
pl-output-buffer)
|
||||
"ab")
|
||||
|
||||
(pl-s-test!
|
||||
"write of bound var walks binding"
|
||||
(begin
|
||||
(pl-output-clear!)
|
||||
(pl-solve-once!
|
||||
pl-s-empty-db
|
||||
(pl-s-goal "=(X, hello), write(X)" {})
|
||||
(pl-mk-trail))
|
||||
pl-output-buffer)
|
||||
"hello")
|
||||
|
||||
(pl-s-test!
|
||||
"write then nl"
|
||||
(begin
|
||||
(pl-output-clear!)
|
||||
(pl-solve-once!
|
||||
pl-s-empty-db
|
||||
(pl-s-goal "write(hi), nl" {})
|
||||
(pl-mk-trail))
|
||||
pl-output-buffer)
|
||||
"hi\n")
|
||||
|
||||
(define pl-solve-tests-run! (fn () {:failed pl-s-test-fail :passed pl-s-test-pass :total pl-s-test-count :failures pl-s-test-failures}))
|
||||
|
||||
Reference in New Issue
Block a user