clpb dominos is now working plus some performnce speedup

parent 5d56a004
......@@ -100,6 +100,7 @@ PSSOURCES = \
language/prolog/modules/boot/expand.pl \
language/prolog/modules/boot/dcg.pl \
language/prolog/modules/library/error.pl \
language/prolog/modules/library/vhash.scm \
language/prolog/modules/library/pairs.pl \
language/prolog/modules/library/lists.pl \
language/prolog/modules/library/dcg_basics.pl \
......
This diff is collapsed.
......@@ -8,7 +8,7 @@
#:use-module (language prolog modules boot dcg)
#:pure
#:duplicates (last replace)
#:replace (sat taut labeling sat_count ~ #{#}#))
#:replace (sat taut card labeling sat_count ~ #{#}#))
(clear-directives)
((@ (guile) eval-when) (compile load eval)
((@ (guile) fluid-set!)
......
......@@ -38,7 +38,8 @@
syntax_error/1, % +Culprit
must_be/2, % +Type, +Term
is_of_type/2 % +Type, +Term
is_of_type/2, % +Type, +Term
list/1 % used in type deductions
]).
:- set_prolog_flag(generate_debug_info, false).
......@@ -261,6 +262,12 @@ not_a_rational(X) :-
; type_error(rational,X)
).
element_types([], _).
element_types([H|T], Type) :-
has_type(Type, H),
element_types(T, Type).
%% is_of_type(+Type, @Term) is semidet.
%
% True if Term satisfies Type.
......@@ -335,11 +342,6 @@ text(X) :-
; codes(X)
), !.
element_types([], _).
element_types([H|T], Type) :-
has_type(Type, H),
element_types(T, Type).
is_list_or_partial_list(L0) :-
'$skip_list'(_, L0,L),
( var(L) -> true ; L == [] ).
......
(define-module (language prolog modules library vhash)
#:use-module (logic guile-log)
#:use-module (logic guile-log prolog goal-transformers)
#:use-module (logic guile-log vlist)
#:export (empty_assoc put_assoc get_assoc assoc_to_list))
(<define> (empty_assoc X) (<=> X vlist-null))
(<define> (put_assoc HEntry H0 Node H)
(<let> ((HEntry (<scm> HEntry))
(H0 (<lookup> H0)))
(<=> H ,(vhash-cons HEntry Node H0))))
(<define> (get_assoc HEntry H0 Node)
(<let> ((HEntry (<scm> HEntry))
(H0 (<lookup> H0))
(V (vhash-ref H0 HEntry #f)))
(when V (<=> Node V))))
(<define> (assoc_to_list H L)
(<=> L ,(map (lambda (k) (vector (list gop2- (car k) (cdr k))))
(vhash->assoc (<lookup> H)))))
......@@ -125,6 +125,7 @@
(define old #f)
(define clear #f)
(define endl #f)
(define profile #f)
(let*
((l (with-input-from-port port
(lambda ()
......@@ -149,6 +150,8 @@
action)
(else
(case action
((profile pr)
(set! profile #t))
((rec) (begin
(fluid-set! -rec?- #t)
(fluid-set! -nonrec?- #f)))
......@@ -282,7 +285,13 @@ HELP FOR PROLOG COMMANDS
(lambda ()
((@@ (system repl command) meta-command) repl)))
(set! str "do[#f]"))
`((@ (guile) begin)
(let ((lam (lambda (x)
(if profile
`((@ (statprof) statprof)
((@@ (guile) lambda) () ,x))
x))))
(lam `((@ (guile) begin)
((@@ (logic guile-log prolog run) prolog-run-0)
(@@ (logic guile-log guile-prolog interpreter)
conversation1)
......@@ -292,7 +301,7 @@ HELP FOR PROLOG COMMANDS
(nn? nn?)
(else
'(@ (logic guile-log iso-prolog) false))))
((@ (guile) if) #f #f))))
((@ (guile) if) #f #f))))))
(else
`((@ (guile) with-fluids)
(((@ (system base language) *current-language*)
......
......@@ -3,7 +3,7 @@
#:replace
(
op2+ op2- op1- #{\\}# op2* op2/ //
** << >> #{/\\}# #{\\/}# op2< op2> op2>= op2=< =:= #{=\\=}#
** ^ << >> #{/\\}# #{\\/}# op2< op2> op2>= op2=< =:= #{=\\=}#
))
(define op2+ gop2+)
......@@ -14,6 +14,7 @@
(define op2/ gop2/)
(define // g//)
(define ** g**)
(define ^ g^)
(define << g<<)
(define >> g>>)
(define #{/\\}# #{g/\\}#)
......
......@@ -31,7 +31,7 @@
#:use-module ((guile) #:select (@ @@ quote unquote random eval-when))
#:use-module ((logic guile-log umatch) #:select (gp-var!))
#:export (reset-flags reset-prolog set)
#:replace (sort)
#:replace (sort load)
#:re-export (;;swi stuff
meta_predicate public
memberchk $skip_list is_list
......@@ -58,6 +58,7 @@
msort
random set_random
clpfd_monotonic
clpb_validation
add_term_expansion
add_term_expansion_temp
expand_term
......@@ -68,6 +69,7 @@
same_length
same_term
;; guile-log
macro multibute
......@@ -84,7 +86,7 @@
module-optable-set!
module-optable-ref
set-module-optable-from-current
;;unknown cludge
gp-var!
......@@ -195,12 +197,15 @@
*term-expansions*
*goal-expansions*
*swi-standard-operators*
min max
)
#:export (make-unbound-term
default_module
re-export-iso-operators
;SWI Stuff
$member $append))
$member $append pp_dyn
))
(define reset-flags init-flags)
(define (reset-prolog)
......@@ -238,3 +243,16 @@ unique([],[]).
sort(X,L) :- msort(X,LL),unique(LL,L).
")
(<define> (pp_dyn x y) (<pp-dyn> x y))
(define-guile-log load
(lambda (x)
(pk (syntax->datum x))
(syntax-case x ()
((load w x)
#'(parse<> w (<code> (load-prolog (<lookup> x)))))
(load
#'(let ((load (lambda (s p cc x)
(load-prolog (gp-lookup x s))
(cc s p))))
load)))))
......@@ -386,7 +386,7 @@
(<or> (cut s p cc)
(<let> ((ss S))
(<and> (<and!> pred)
(<with-fail> p
(<with-fail> (lambda () (p))
(<code> (gp-clear-frame! ss))
a)))
b))))
......@@ -411,10 +411,10 @@
(p)))
((_ (cut s p cc) pred a b)
(let ((p2 (lambda () (parse<> (cut s p cc) b))))
(let ((p2f (lambda () (parse<> (cut s p cc) b))))
(let ((cc2 (lambda (s3 p3)
(parse<> (cut s3 p cc) a))))
(parse<> (cut s p2 cc2) pred))))))
(parse<> (cut s p2f cc2) pred))))))
......@@ -857,8 +857,8 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
((_ (m nm dd) (pr ...) args v ((a)) ((b) ...) (cut s p cc))
(let ((del (fluid-ref delayers)))
(umatch (#:clear del #:dual dd #:mode m #:status s
#:tag <next> #:name nm) ()
((dls-match (cut s <next> cc) del b))
#:tag <nex> #:name nm) ()
((dls-match (cut s <nex> cc) del b))
...
((dls-match (cut s p cc) del a)))))
......@@ -1026,11 +1026,12 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
(apply (gp-lookup F S) S P CC L))
(define (->list s l)
(umatch (#:mode - #:status s #:name ->list) (l)
((x . l)
(cons x (->list s l)))
(x '())))
(let ((l (gp-lookup l s)))
(if (pair? l)
(cons (car l) (->list s (cdr l)))
(if (gp-pair- l s)
(cons (gp-car l s) (->list s (gp-cdr l s)))
'()))))
(define-syntax def00
(lambda (x)
......@@ -1229,14 +1230,15 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(define-syntax-rule (attvar? x) (gp-attvar? (gp-lookup x S) S))
(<define> (<attvar?> x) (if (gp-attvar? x S) <cc> <fail>))
(<define> (<attvar-raw?> x) (if (gp-attvar-raw? x S) <cc> <fail>))
(<define> (<put-attr> x m v) (<let> ((s (gp-put-attr x m v S)))
(<with-s> s <cc>)))
(<define> (<put-attr> x m v)
(<code> (gp-put-attr x m v S)))
(<define> (<put-attr-guarded> x m v)
(<let> ((s (gp-put-attr-guarded x m v S)))
(<with-s> s <cc>)))
(<code> (gp-put-attr-guarded x m v S)))
(<define> (<put-attr-weak-guarded> x m v)
(<let> ((s (gp-put-attr-weak-guarded x m v S)))
(<with-s> s <cc>)))
(<code> (gp-put-attr-weak-guarded x m v S)))
(<define> (<get-attrs> x m v)
(<let> ((x (<lookup> x)))
(when (gp-attvar-raw? x S)
......@@ -1259,7 +1261,7 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(<r=> v ret)
(doit_on))))
(<define> (<del-attr> x m) (<with-s> (gp-del-attr x m S) <cc>))
(<define> (<del-attr> x m) (<code> (gp-del-attr x m S)))
(define (tr-meta f fnew)
......@@ -1296,66 +1298,69 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(<match> a b (pat ... (<cut> l)) ...))
(<define> (attributeU val var x)
(<let*> ((item
(gp-att-raw-var var S))
(attdxy
(gp-att-data var S))
(attdx
(let lp ((l attdxy))
(if (pair? l)
(if (pair? (caar l))
(if (caaar l)
(cons (car l) (lp (cdr l)))
(lp (cdr l)))
(lp (cdr l)))
'())))
(attdy
(let lp ((l attdxy))
(if (pair? l)
(if (pair? (caar l))
(if (cdaar l)
(cons (car l) (lp (cdr l)))
(<let*> ((item (<lookup> (gp-att-raw-var var S))))
(cond
((eq? val var)
<cc>)
((<var?> val)
(if x
(<set> val var)
(<==> val item)))
((not (<var?> item))
(if x
(<=> val item)
(<==> val item)))
(else
(<let*> ((attdxy (gp-att-data var S))
(attdx
(let lp ((l attdxy))
(if (pair? l)
(if (pair? (caar l))
(if (caaar l)
(cons (car l) (lp (cdr l)))
(lp (cdr l)))
(lp (cdr l)))
(cons (car l) (lp (cdr l))))
'()))))
(<and>
(if (eq? val var)
<cc>
(if (<var?> val)
(if x
(<set> val var)
(<==> val item))
(<and>
(<recur> lp ((d attdx))
(if (pair? d)
(if (pair? (car d))
(<let> ((lam (caar d)))
(if (object-property
lam
(@@ (logic guile-log code-load) delayed-id))
(lam var val x)
(lam (cdar d) val x))
(lp (cdr d)))
(error
"Bugger Error, wring format in attribute" (car d)))
<cc>))
(if x
(<=> val item)
(<==> val item))
'())))
(attdy
(let lp ((l attdxy))
(if (pair? l)
(if (pair? (caar l))
(if (cdaar l)
(cons (car l) (lp (cdr l)))
(lp (cdr l)))
(cons (car l) (lp (cdr l))))
'()))))
(<recur> lp ((d attdx))
(if (pair? d)
(if (pair? (car d))
(<let> ((lam (caaar d)))
(if (object-property
lam
(@@ (logic guile-log code-load) delayed-id))
(lam var val x)
(lam (cdar d) val x))
(lp (cdr d)))
(error
"Bugger Error, wring format in attribute" (car d)))
<cc>))
(if x
(<=> val item)
(<==> val item))
(<recur> lp ((d attdy))
(if (pair? d)
(if (pair? (car d))
(<let*> ((lam (caar d))
(lam (if (pair? lam) (cdr lam) lam)))
(if (object-property
lam
(@@ (logic guile-log code-load) delayed-id))
(lam var val x)
(lam (cdar d) val x))
(lp (cdr d)))
(error "Bugger Error, wring format in attribute" (car d)))
<cc>))))))))
(<recur> lp ((d attdy))
(if (pair? d)
(if (pair? (car d))
(<let*> ((lam (caar d))
(lam (if (pair? lam) (cdr lam) lam)))
(if (object-property
lam
(@@ (logic guile-log code-load) delayed-id))
(lam var val x)
(lam (cdar d) val x))
(lp (cdr d)))
(error
"Bugger Error, wring format in attribute" (car d)))
<cc>)))))))
(set! (@@ (logic guile-log code-load) attributeU) attributeU)
......@@ -208,7 +208,7 @@
((not (or (<var?> prio) (integer? prio)))
(domain_error operator_priority prio))
((not (or (<var?> spec) (member spec spec-list)))
(domain_error operator_specifier spec))
(domain_error operator_specifier (pk spec)))
((not (or (<var?> op) (procedure? op) (string? op)))
(domain_error atom op))
(else
......@@ -227,8 +227,7 @@
(_
(<cut> (lp2 (cdr xx)))))))))))))
(<define> (op prio op_spec operator)
(<let> ((operator (proj (<scm> operator)))
(prio (<scm> prio))
......@@ -257,7 +256,7 @@
(domain_error operator_priority prio))
((not (member op_spec spec-list))
(domain_error operator_specifier op_spec))
(domain_error operator_specifier (pk op_spec)))
((and (atom? operator) (equal? operator ","))
(permission_error modify operator ","))
......@@ -368,6 +367,7 @@
(,double_quotes #t ,atom ,chars ,codes ,atom)
(,generate_debug_info #t ,false ,true ,false)
(,clpfd_monotonic #t ,false ,true ,false)
(,clpb_validation #t ,false ,true ,false)
(,debug_term_position #t ,false ,true ,false)))
(for-each
(lambda (x)
......
......@@ -70,7 +70,7 @@
(<and>
(existence_error "undefined_global_variable" atom)
(lp))
(<=> val r)))))
(<=> val ,(<lookup> r))))))
((string? atom)
(<let> ((mod (current-module))
(sym (string->symbol atom)))
......
......@@ -55,7 +55,8 @@
gop2+ gop2- gop1- gop1+
#{g\\}# gop2* gop2/ g// gop2rem gop2mod
g** g<< g>> #{g/\\}# #{g\\/}# gop2< gop2> gop2>= gop2=< g=:=
g** g^
g<< g>> #{g/\\}# #{g\\/}# gop2< gop2> gop2>= gop2=< g=:=
#{g=\\=}#
#{;}#
......@@ -401,7 +402,8 @@
(mk-scheme-biop 'yfx "*" tr-*g gop2* * s s)
(mk-scheme-biop 'yfx "/" tr-/g gop2/ / s s)
(mk-scheme-biop 'yfx "//" tr-i/g g// truncate/ s s)
(mk-scheme-biop 'xfx "**" tr-powg g** myexpt s s)
(mk-scheme-biop 'xfx "**" tr-powg g** expt s s)
(mk-scheme-biop 'xfx "^" tr-pow2g g^ expt s s)
(mk-scheme-biop 'yfx "<<" tr-shrg g<< ash s s)
(mk-scheme-biop 'yfx ">>" tr-shrg g>> shr s s)
(mk-scheme-biop 'yfx "/\\" tr-bitandg #{g/\\}# logand s s)
......@@ -598,7 +600,7 @@ floor(x) (floor x)
((x) (lp x))
(((_ _ (or "<" ">" "=<" ">=" "==" "=:=" "=\\=") _) a b n2 m2)
#`(<fast-if> #,(goal stx i) #,(goal stx t) #,(goal stx y)))
#`(<if> #,(goal stx i) #,(goal stx t) #,(goal stx y)))
(_
#`(<if> #,(goal stx i) #,(goal stx t) #,(goal stx y))))))
(_
......@@ -974,6 +976,7 @@ floor(x) (floor x)
(name-as gop2/ op2/)
(name-as g// //)
(name-as g** **)
(name-as g^ ^)
(name-as g<< <<)
(name-as g>> >>)
(name-as #{g/\\}# #{/\\}#)
......
......@@ -130,15 +130,16 @@
;;We do not, use eval-scm to eval objects in scm contexts
(define (scm stx x)
(define (sarg stx x) #``#,(arg stx x))
(define (sscm stx x) (scm stx x))
(match (pp 'scm x)
(((kind _ "-" _) (#:number x . _) n m)
(- x))
(((kind _ op _) x y n m)
(f->stxfkn #f op #f #f sarg #:scm stx 2 n m (list x y)))
(f->stxfkn #f op #f #f sscm #:scm stx 2 n m (list x y)))
(((kind _ op _) x n m)
(f->stxfkn #f op #f #f sarg #:scm stx 1 n m (list x)))
(f->stxfkn #f op #f #f sscm #:scm stx 1 n m (list x)))
((#:group x)
(scm stx x))
......@@ -152,11 +153,11 @@
((#:number x . _) x)
((and atom (#:atom f _ _ n m))
(f->stxfkn #f f #f atom sarg #:scm stx #f n m '()))
(f->stxfkn #f f #f atom sscm #:scm stx #f n m '()))
((#:term (and atom (#:atom f . _)) l #f n m)
(let ((l (get.. "," l)))
(f->stxfkn #f f #f atom sarg #:scm stx #f n m l)))))
(f->stxfkn #f f #f atom sscm #:sscm stx #f n m l)))))
(define (add x y z n m)
(if z
......
......@@ -4,6 +4,169 @@
#:use-module (system base language)
#:export (load-prolog ensure_loaded ensure_loaded_))
(define* (load-in-vicinity-q dir file-name #:optional reader)
"Load source file FILE-NAME in vicinity of directory DIR. Use a
pre-compiled version of FILE-NAME when available, and auto-compile one
when none is available, reading FILE-NAME with READER."
;; The auto-compilation code will residualize a .go file in the cache
;; dir: by default, $HOME/.cache/guile/2.0/ccache/PATH.go. This
;; function determines the PATH to use as a key into the compilation
;; cache.
(define (canonical->suffix canon)
(cond
((and (not (string-null? canon))
(file-name-separator? (string-ref canon 0)))
canon)
((and (eq? (system-file-name-convention) 'windows)
(absolute-file-name? canon))
;; An absolute file name that doesn't start with a separator
;; starts with a drive component. Transform the drive component
;; to a file name element: c:\foo -> \c\foo.
(string-append file-name-separator-string
(substring canon 0 1)
(substring canon 2)))
(else canon)))
(define compiled-extension
;; File name extension of compiled files.
(cond ((or (null? %load-compiled-extensions)
(string-null? (car %load-compiled-extensions)))
(warn "invalid %load-compiled-extensions"
%load-compiled-extensions)
".go")
(else (car %load-compiled-extensions))))
(define (more-recent? stat1 stat2)
;; Return #t when STAT1 has an mtime greater than that of STAT2.
(or (> (stat:mtime stat1) (stat:mtime stat2))
(and (= (stat:mtime stat1) (stat:mtime stat2))
(>= (stat:mtimensec stat1)
(stat:mtimensec stat2)))))
(define (fallback-file-name canon-file-name)
;; Return the in-cache compiled file name for source file
;; CANON-FILE-NAME.
;; FIXME: would probably be better just to append
;; SHA1(canon-file-name) to the %compile-fallback-path, to avoid
;; deep directory stats.
(and %compile-fallback-path
(string-append %compile-fallback-path
(canonical->suffix canon-file-name)
compiled-extension)))
(define (compile file)
;; Compile source FILE, lazily loading the compiler.
(with-fluids ((*current-language* (lookup-language 'scheme)))
((module-ref (resolve-interface '(system base compile))
'compile-file)
file
#:opts %auto-compilation-options
#:env (current-module))))
;; Returns the .go file corresponding to `name'. Does not search load
;; paths, only the fallback path. If the .go file is missing or out
;; of date, and auto-compilation is enabled, will try
;; auto-compilation, just as primitive-load-path does internally.
;; primitive-load is unaffected. Returns #f if auto-compilation
;; failed or was disabled.
;;
;; NB: Unless we need to compile the file, this function should not
;; cause (system base compile) to be loaded up. For that reason
;; compiled-file-name partially duplicates functionality from (system
;; base compile).
(define (fresh-compiled-file-name name scmstat go-file-name)
;; Return GO-FILE-NAME after making sure that it contains a freshly
;; compiled version of source file NAME with stat SCMSTAT; return #f
;; on failure.
(false-if-exception
(let ((gostat (and (not %fresh-auto-compile)
(stat go-file-name #f))))
(if (and gostat (more-recent? gostat scmstat))
go-file-name
(begin
(if gostat
(format (current-warning-port)
";;; note: source file ~a\n;;; newer than compiled ~a\n"
name go-file-name))
(cond
(%load-should-auto-compile
(%warn-auto-compilation-enabled)
(format (current-warning-port) ";;; compiling ~a\n" name)
(let ((cfn (compile name)))
(format (current-warning-port) ";;; compiled ~a\n" cfn)
cfn))
(else #f)))))
#:warning "WARNING: compilation of ~a failed:\n" name))
(define (sans-extension file)
(let ((dot (string-rindex file #\.)))
(if dot
(substring file 0 dot)
file)))
(define (load-absolute abs-file-name)
;; Load from ABS-FILE-NAME, using a compiled file or auto-compiling
;; if needed.
(define scmstat
(false-if-exception
(stat abs-file-name)
#:warning "Stat of ~a failed:\n" abs-file-name))
(define (pre-compiled)
(and=> (search-path %load-compiled-path (sans-extension file-name)
%load-compiled-extensions #t)
(lambda (go-file-name)
(let ((gostat (stat go-file-name #f)))
(and gostat (more-recent? gostat scmstat)
go-file-name)))))
(define (fallback)
(and=> (false-if-exception (canonicalize-path abs-file-name))
(lambda (canon)
(and=> (fallback-file-name canon)
(lambda (go-file-name)
(fresh-compiled-file-name abs-file-name
scmstat
go-file-name))))))
(let ((compiled (and scmstat (or (pre-compiled) (fallback)))))
(if compiled
(begin
(if %load-hook
(%load-hook abs-file-name))
(load-compiled compiled))
(start-stack 'load-stack
(primitive-load abs-file-name)))))
(save-module-excursion
(lambda ()
(with-fluids ((current-reader reader)
(%file-port-name-canonicalization 'relative))
(cond
((absolute-file-name? file-name)
(load-absolute file-name))
((absolute-file-name? dir)
(load-absolute (in-vicinity dir file-name)))
(else
(load-from-path (in-vicinity dir file-name))))))))
(define-syntax load-q
(make-variable-transformer
(lambda (x)
(let* ((src (syntax-source x))
(file (and src (assq-ref src 'filename)))
(dir (and (string? file) (dirname file))))
(syntax-case x ()
((_ arg ...)
#`(load-in-vicinity-q #,(or dir #'(getcwd)) arg ...))
(id
(identifier? #'id)
#`(lambda args
(apply load-in-vicinity-q #,(or dir #'(getcwd)) args))))))))
(define (process-use_module module-interface-args)
(with-fluids ((*current-language* (lookup-language 'scheme)))
(let ((interfaces (map (lambda (mif-args)
......@@ -12,18 +175,12 @@
module-interface-args)))
(module-use-interfaces! (current-module) interfaces))))
(define (load-prolog s p cc str)
(with-fluids ((*current-language* (lookup-language 'scheme)))