Initial commit

parents
This diff is collapsed. Click to expand it.
GNU Lesser General Public License (LGPL) version 2
This is a logic programming framework for guile
Copyright (c) Stefan Israelsson Tampe.
See "COPYING.LIB" for more information about the license.
GNU Lesser General Public License (LGPL) version 2
This is a port of racket-5.1 version of contracts which are
under,
Copyright (c) 2010-2011 PLT Scheme Inc.
With changes by Stefan Israelsson Tampe in order to make it work under
guile
See "COPYING.LIB" for more information about the license.
This is a draft for guile-2.0.6 and later and works for linux.
Add this directory to guiles load-path
Install:
Go to logic/guile-log/src/
issue
make
Now you are ready to use it from guile through,
> (use-modules (logic guile-log))
Have fun!
(define-module (logic guile-log)
#:use-module (system base compile)
#:use-module (ice-9 match-phd)
#:use-module (logic guile-log guile-log-pre)
#:use-module (logic guile-log umatch)
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:use-module (system repl repl)
#:re-export (u-cons u-abort u-var! u-scm u-unify! u-unify-raw!)
#:export (umatch))
(define-syntax umatch (syntax-rules () ((a . l) (um . l))))
(define log-module
(resolve-module
'(logic guile-log)))
(include-from-path "logic/guile-log/macros.scm")
(define-module (logic guile-log guile-log-pre)
#:export (define-guile-log guile-log-macro? log-code-macro log-code-macro?))
(define (guile-log-macro? s)
(and (symbol? s) (symbol-property s 'guile-log-macro?)))
(define (log-code-macro? s)
(and (symbol? s) (symbol-property s 'log-code-macro?)))
(define (log-code-macro s)
(set-symbol-property! s 'log-code-macro? #t))
(define-syntax define-guile-log
(lambda (x)
(syntax-case x ()
((_ n . l)
#'(begin
(set-symbol-property! 'n 'guile-log-macro? #t)
(define-syntax n . l))))))
;; sematically after kanrens all-interleave
(define-guile-log <or!>
(syntax-rules ()
((_ w)
(parse<> w <fail>))
((_ w a)
(parse<> w a))
((_ w a ...)
(parse<> w (interleave (list (</.> a) ...))))))
(define (interleave p cc l)
(let ((s (gp-store-state)))
(gp-swap-to-b)
(let* ((ul (u-var!))
(ur (u-var!))
(n (u-var!))
(fr (gp-newframe)))
(u-set! n 0)
(gp-swap-to-a)
(letrec ((loop (lambda (l r)
(if (null? l)
(if (null? r)
(p)
(loop (reverse r) '()))
(begin
(gp-swap-to-b)
(u-set! ul l)
(u-set! ur r)
(gp-swap-to-a)
((car l)))))))
(define (unwind-if-more-then-one-set)
(begin
(gp-swap-to-b)
(let ((m (gp-lookup n)))
(if (= m 1)
(gp-unwind 2)
(u-set! n (+ m 1))))
(gp-swap-to-a)))
(loop
(map (lambda (a)
(lambda ()
(gp-restore-state s)
(a
(lambda ()
(loop (cdr (gp-lookup ul))
(gp-lookup ur)))
(lambda (pp)
(cc (let* ((s (gp-store-state))
(l (gp-lookup ul))
(r (gp-lookup ur)))
(unwind-if-more-then-one-set)
(lambda ()
(loop (cdr l)
(cons (lambda ()
(gp-restore-state s)
(pp))
r)))))))))
l)
'())))))
LIBS = `pkg-config --libs guile-2.0`
CFLAGS = `pkg-config --cflags guile-2.0`
libguile-unify.so : unify.h unify.c unify-undo-redo.c unify.x
gcc $(LIBS) $(CFLAGS) -shared -o libguile-unify.so -fPIC unify.c
unify.x : unify.h unify.c unify-undo-redo.c
guile-snarf -o unify.x $(CFLAGS) unify.c
/*
Copyright (C) 2009, 2010 Free Software Foundation, Inc.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#define Q(x) ((((scm_t_bits) x) << 2) + 2)
#define Ix (SCM_UNPACK(*pat))
#define i_end Q(0)
#define i_cons Q(1)
#define i_var Q(2)
#define i_eq Q(3)
#define i_pop Q(4)
#define i_insert Q(5)
#define i_unify Q(6)
#define i_match Q(7)
#define i_scheme Q(8)
#define i_load Q(9)
#define i_arbr Q(10)
SCM_API SCM gp_swap_a();
SCM_API SCM gp_swap_b();
SCM_API SCM gp_gp(SCM scm);
SCM_API SCM gp_varp(SCM x);
SCM_API SCM gp_atomicp(SCM x);
SCM_API SCM gp_consp(SCM x);
SCM_API SCM gp_set(SCM var, SCM val);
SCM_API SCM gp_ref_set(SCM var, SCM val);
SCM_API SCM gp_clear();
SCM_API SCM gp_gp_newframe();
SCM_API SCM gp_mkvar();
SCM_API SCM smob2scm(SCM scm);
SCM_API SCM gp_gp_unify(SCM scm1, SCM scm2);
SCM_API SCM gp_gp_lookup(SCM scm);
SCM_API SCM gp_var_number(SCM x);
SCM_API SCM gp_soft_init();
SCM_API SCM gp_cons_bang(SCM car, SCM cdr);
SCM_API SCM gp_pair_bang(SCM x);
SCM_API SCM gp_pair(SCM x);
SCM_API SCM gp_null(SCM x);
SCM_API SCM gp_null_bang(SCM x);
SCM_API SCM gp_gp_lookup(SCM x);
SCM_API SCM gp_m_unify(SCM x, SCM y);
SCM_API SCM gp_gp_cdr(SCM x);
SCM_API SCM gp_car(SCM x);
SCM_API SCM gp_gp_unwind(SCM fr);
SCM_API SCM gp_gp_store_state();
SCM_API SCM gp_gp_restore_state(SCM cont);
SCM_API SCM gp_make_fluid();
SCM_API SCM gp_fluid_set_bang(SCM f, SCM v);
SCM_API SCM gp_dynwind(SCM in, SCM out);
SCM_API SCM gp_copy(SCM x);
;;; UNIFY MATCH MATCHER COMPILER
;; Copyright (C) 2001,2008,2009,2010 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
(define-module (logic guile-log umatch)
#:use-module (ice-9 match-phd-lookup)
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:export (gp-clear gp-unify! gp-unify-raw! gp-newframe gp-unwind gp-var!
gp->scm scm->gp gp-atom fast-match def
gp-print
gp-budy gp-swap-to-a gp-swap-to-b gp-m-unify!
fun *gp-fi* g-member g-iright u-prompt
u-abort u-set! u-var! u-call u-deref gp-atomic?
u-context u-modded
u-unify! u-scm u-unify-raw! u-cons gp-lookup
gp-var? gp-cons? gp-cons! let-alias gp-set! u-list
gp-printer gp-var-number
gp-car gp-cdr
gp-store-state gp-restore-state
gp-make-fluid gp-fluid-set! gp-fluid-ref with-gp-fluids
u-dynwind umatch um <umatch> gp-copy))
;;need to add modded,
(define gp-module-init #f)
(define gp? #f)
(define gp-pair? #f)
(define gp-car #f)
(define gp-cdr #f)
(load-extension (%search-load-path "logic/guile-log/src/libguile-unify.so")
"gp_init")
(gp-module-init)
(use-modules (srfi srfi-11))
(define (get-line x u)
(if (gp? x)
(let ((x (gp-lookup x)))
(if (and (gp? x) (gp-pair? x))
(get-line (gp-cdr x) (cons (gp-car x) u))
(if (null? x)
(values (reverse u) '())
(values (reverse u) x))))
(values (reverse u) x)))
(define (gp-printer port x)
(define (f l d)
(if (eq? (length l) 1)
(format port "<#gp {~{~a~}~a}>" l d)
(format port "<#gp {~a ~{ ~a~}~a}>" (car l) (cdr l) d)))
(let ((x (gp-lookup x)))
(if (gp? x)
(if (gp-pair? x)
(let-values (((l d) (get-line x '())))
(if (null? x)
(f l "")
(f l (format #f " . ~a" d))))
(let ((varn (gp-var-number x)))
(format port "<#~a>" varn)))
(format port "<#gp ~a>" x))))
(define gp-fluid-ref gp-lookup)
(define-syntax with-gp-fluids
(syntax-rules ()
((_ ((f v) ...) code ...)
(begin
(u-set! f v)
...
code
...))))
(define-syntax u-dynwind
(syntax-rules ()
((_ pre action post)
(let ((p pre))
(p)
(gp-dynwind p post)
(action)))))
;;prompts will be just a continuation lambda
(define-syntax u-prompt
(syntax-rules ()
((_ x) x)))
(define-syntax u-abort
(syntax-rules ()
((_ x) (x))))
(define-syntax u-call
(syntax-rules ()
((_ g f ...) (f ...))))
(define-syntax u-var!
(syntax-rules ()
((_) (gp-var!))))
(define-syntax u-scm
(syntax-rules ()
((_ x) (gp->scm x))))
(define-syntax u-set!
(syntax-rules ()
((_ x y) (gp-set! x y))))
(define-syntax u-cons
(syntax-rules ()
((_ x y) (gp-cons! x y))))
(define-syntax u-unify!
(syntax-rules ()
((_ x y) (gp-unify! x y))))
(define-syntax u-unify-raw!
(syntax-rules ()
((_ x y) (gp-unify-raw! x y))))
(define-syntax u-modded
(syntax-rules ()
((_) #t)))
(define (id x) x)
(make-phd-matcher umatch0
( (gp-car gp-cdr gp-pair!? gp-null!? gp-unify! gp-lookup)
( (+ (gp-car gp-cdr gp-pair!? gp-null!? gp-unify! gp-lookup))
(++ (gp-car gp-cdr gp-pair!? gp-null!? gp-unify-raw! gp-lookup))
(- (gp-car gp-cdr gp-pair? gp-null? gp-m-unify! gp-lookup))
(* ( car cdr pair? null? equal? id)))))
(define-syntax umatch
(lambda (x)
(syntax-case x ()
((umatch . l)
(with-syntax ((w (datum->syntax (syntax l) '*gp-fi*)))
(syntax (umatch* "anon" w #f * . l)))))))
;;unsyntax construct that works quite ok
(define (pp x) (pretty-print x) x)
(define-syntax umatch*
(lambda (x)
(syntax-case x ()
((umatch* nn tt rr mm #:name n . l)
(syntax (umatch* n tt rr mm . l)))
((umatch* nn tt rr mm #:tag t . l)
(syntax (umatch* nn t rr mm . l)))
((umatch* nn tt rr mm #:raw . l)
(syntax (umatch* nn tt #t mm . l)))
((umatch* nn tt rr mm #:mode m . l)
(syntax (umatch* nn tt rr m . l)))
((umatch* n t r m args a ...)
(syntax (umatch** (a ...) () args (n t r m)))))))
(define-syntax umatch**
(lambda (x)
(syntax-case x ()
((_ . l)
;(pk `(umatch** ,@(syntax->datum #'l)))
#'(umatch**+ . l)))))
(define-syntax umatch**+
(syntax-rules ()
((_ ((code) ...) a . l) (umatch*** (code ...) a . l))
((_ ((a as ...) ...) () . l)
(umatch** ((as ...) ...) ((a) ...) . l))
((_ ((a as ...) ...) ((b ...) ...) . l)
(umatch** ((as ...) ...) ((b ... a) ...) . l))))
(define-syntax umatch***
(lambda (x)
(syntax-case x ()
((_ . l)
;(pk `(umatch*** ,@(syntax->datum #'l)))
#'(umatch***+ . l)))))
(define (ppq a x)
;(pk `(,a ,x))
x)
(define-syntax mk-failure
(syntax-rules ()
((_ fr code)
(letrec ((base (case-lambda
(()
(gp-unwind fr)
code)
((x)
(gp-unwind fr)
(let ((s (gp-store-state)))
(letrec ((self (case-lambda
(() (base))
((x) self))))
self))))))
base))))
(define-syntax umatch***+
(syntax-rules (+)
((_ (code ...) () () (n t _ _))
(let ((frame (ppq 'new (gp-newframe))))
(umatch0 (#:args)
((arguments) (-> t (mk-failure frame))
code)
...
(_ (error (format #f "umatch ~a did not match" n))))))
((_ (code ...) ((a ...) ...) arg (n t #t +))
(let ((frame (ppq 'new (gp-newframe))))
(umatch0 (#:args . arg)
((arguments (++ ++ a) ...)
(-> t (mk-failure frame))
code)
...
(_ (error (format #f "umatch ~a did not match" n))))))
((_ (code ...) ((a ...) ...) arg (n t r m))
(let ((frame (ppq 'new (gp-newframe))))
(umatch0 (#:args . arg)
((arguments (m m a) ...)
(-> t (mk-failure frame))
code)
...
(_ (error (format #f "umatch ~a did not match" n))))))))
(define-syntax um (syntax-rules () ((a . l) (umatch . l))))
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