parent e9cad52a
What it is:
Guile log is a logic programming framework that has strong continuation
support meaning that stalling of algorithm is well supported. It also
sports most of the logic programming features you see in common prolog
softwares like swi-prolog and guile-log comes with a prolog engine as well as
a minikanren engine as well as an internal scheme interface to logic
programming which is the guile-log interface.
What It can do:
It can do whatever a iso-prolog or swi-prolog can do and contains most prolog
constructs from them. If you want to program guile and perhaps guile-emacs in
prolog this is the main source to go to.
It is good design to base a proof solver on due to the fact that it can save
the state of the program and return to the base interpreter and you can control
your environment as any scheme or prolog environment without making a special
To generate cases for e.g. optimisation or constraint satisfaction. The power
of guile-log comes from the seamless intergration of continuations. You can
postpone a calculation and evaluate all postponed calculations for making a
set of prommissing continuations and take those one step further. It really is
a great tool for all kinds of local searches.
And much much more.
A 64 bit system
......@@ -6,7 +6,7 @@
#:use-module (ice-9 pretty-print)
#:export (make-logger persist))
(define (M x) (lambda (y) (eq? x y)))
(define gp-var 0)
(define var 1)
(define fluid 2)
......@@ -27,11 +27,110 @@
(define set-struct 26)
(define set-gp-pair 28)
(define (hash->assoc h)
(lambda (k v l) (cons (cons k v) l))
'() h))
(define (assoc->hash l)
(let lp ((h (make-hash-table)) (l l))
(if (pair? l)
(let ((k.v (car l)))
(hash-set! h (car k.v) (cdr k.v))
(lp h (cdr l)))
(define-syntax-rule (ket self l ...)
(letrec ((self (let l ...))) self))
(define (unserialize log)
(define lmap (make-hash-table))
(let lp ((l (reverse (log data))))
(if (pair? l)
(match (car l)
(((? (M gp-var)) i)
(let ((v (gp-make-variable)))
(log 'reg-obj i v)))
(((? (M var)) i)
(let ((v (make-variable)))
(log 'reg-obj i v)))
(((? (M fluid)) i)
(let ((v (make-fluid)))
(log 'reg-obj i v)))
(((? (M pair)) i)
(let ((v (cons 0 0)))
(log 'reg-obj i v)))
(((? (M vector)) i n)
(let ((v (make-vector n)))
(log 'reg-obj i v)))
(((? (M procedure) i n))
(let ((v (gp-make-null-procedure n)))
(log 'reg-obj i v)))
(((? (M struct))))
(((? (M named)) i path name)
(let ((r (hash-ref lmap path #f)))
(if (not r)
(set! r (resolve-module path))
(if r
(hash-set! lmap path r)
(error "path not possible in unserializing"))))
(let ((r (module-ref r name)))
(if r
(log 'reg-obj i r)
(error (format #f "symbol %a not present in module %a at unserializing" name path))))))
(((? (M gp-pair))))
(((? (M atom)) i a)
(log 'reg-obj i a)
(((? (M set-gp-var))))
(((? (M set-var)) i j)
(let ((v (log 'lookup i))
(x (log 'lookup j)))
(variable-set! v x)))
(((? (M set-fluid)) i j)
(let ((v (log 'lookup i))
(x (log 'lookup j)))
(fluid-set! v x)))
(((? (M set-pair)) i j k)
(let ((v (log 'lookup i))
(x (log 'lookup j)))
(y (log 'lookup k)))
(set-car! v x)
(set-cdr! v y))
(((? (M set-vector)) i l)
(let ((v (log 'lookup i)))
(let lp ((l l) (n 0))
(if (pair? l)
(let ((x (log 'lookup (car l))))
(vector-set! v n x)
(lp (cdr l) (+ n 1)))))))
(((? (M set-procedure)) i l))
(((? (M set-struct) i l)))
(((? (M set-gp-pair)) i j k)))
(lp (cdr l))))))
(define* (make-logger #:key (file "persist.scm"))
(let ((maps (make-hash-table))
(ket self
((maps (make-hash-table))
(imap 0)
(res '())
(i 0)
(tags '())
(i->x (make-hash-table))
(obj->i (make-hash-table))
(atom->i (make-hash-table)))
......@@ -44,6 +143,7 @@
(let ((i (inc)))
(hashq-set! obj->i x i)
(hashq-set! i->obj i x)
(define (update x) (set! res (cons x res)))
......@@ -62,17 +162,36 @@
(let ((i (inc)))
(hash-set! atom->i obj i)
(hash-set! i->x i obj)
(update (begin code ...))
(define (repr)
(list (hash->assoc maps) (reverse res) imap i))
(case kind
(let ((s (open-file file "w")))
(write (repr) s)
(close s)))
(let* ((s (open-file file "w"))
(data (write (repr) s)))
(close s)
(set! maps (assoc->hash (list-ref data 0)))
(set! res (reverse (list-ref data 1)))
(set! imap (listref data 2))
(set! i (list-ref data 3))
(pretty-print (reverse res)))))
(pretty-print (repr)))
((kind i j k l)
(case kind
......@@ -88,6 +207,10 @@
((kind i j)
(case kind
(let ((tag (persist self i j)))
(set! tags (cons tag tags))))
(update `(,set-var ,i ,j)))
......@@ -117,7 +240,7 @@
(let ((path (procedure-property x 'path)))
(if path
(let ((i (inc x)))
(update `(,named ,path ,i))
(update `(,named ,i ,path))
......@@ -220,14 +343,14 @@
(log 'set-vector i l)))))
(define (make-a-procedure)
(let ((i (mk-name 'make-procedure x)))
(let* ((free (program-free-variables x))
(nfree (length free))
(i (mk-name 'make-procedure x nfree)))
(do-if-deep x i
(let* ((addr (program-code x))
(elf (find-mapped-elf-image addr))
(elfaddr (gp-bv-address elf))
(reladdr (- addr elfaddr))
(free (program-free-variables x))
(nfree (length free))
(source (match (program-sources x)
(() #f)
(((_ source . _) . _) source)))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment