once does not ask for more solutions, make clean does not delete off all the .pl files

parent 1415beaa
GOBJECTS = $(SOURCES:%.scm=%.go)
GPOBJECTS = $(SOURCES:%.scm=%.go)
GOBJECTS = $(filter-out %.pl, $(GPOBJECTS))
nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES)
nobase_go_DATA = $(GOBJECTS)
......
......@@ -64,7 +64,6 @@
propagation algorithm from the literature and adding it.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
:- scm[(define kill #f)].
:- module(clpfd, [
op(760, yfx, #<==>),
op(750, xfy, #==>),
......@@ -124,6 +123,8 @@
fd_dom/2
]).
:- scm[(define kill #f)].
:- public % called from goal_expansion
clpfd_equal/2,
clpfd_geq/2.
......@@ -1079,7 +1080,6 @@ intervals_to_domain(Is, D) :-
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% ?Var in +Domain
%
% Var is an element of Domain. Domain is one of:
......
(define-module (language prolog modules library clpfd.pl.scm)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log guile-prolog attribute)
#:replace (#{#>}# #{#<}# #{#>=}# #{#=<}# #{#=}# #{#\\=}# #{#\\}# #{#<==>}# #{#==>}# #{#<==}# #{#\\/}# #{#/\\}# in ins all_different all_distinct sum scalar_product tuples_in labeling label indomain lex_chain serialized global_cardinality global_cardinality circuit cumulative cumulative element automaton automaton transpose zcompare chain fd_var fd_inf fd_sup fd_size fd_dom))
(clear-directives)
(eval-when (compile load eval)
(fluid-set! *prolog-ops* *swi-standard-operators*))
(compile-prolog-string "
:- op(760,yfx,#<==>).
:- op(750,xfy,#==>).
:- op(750,yfx,#<==).
:- op(740,yfx,#\\/).
:- op(730,yfx,#\\).
:- op(720,yfx,#/\\).
:- op(710,fy,#\\).
:- op(700,xfx,#>).
:- op(700,xfx,#<).
:- op(700,xfx,#>=).
:- op(700,xfx,#=<).
:- op(700,xfx,#=).
:- op(700,xfx,#\\=).
:- op(700,xfx,in).
:- op(700,xfx,ins).
:- op(450,xfx,..).
")
(define *public-module-operators* '((760 yfx #{#<==>}#) (750 xfy #{#==>}#) (750 yfx #{#<==}#) (740 yfx #{#\/}#) (730 yfx #{#\}#) (720 yfx #{#/\}#) (710 fy #{#\}#) (700 xfx #{#>}#) (700 xfx #{#<}#) (700 xfx #{#>=}#) (700 xfx #{#=<}#) (700 xfx #{#=}#) (700 xfx #{#\=}#) (700 xfx in) (700 xfx ins) (450 xfx ..) ))
(compile-prolog-file "/home/stis/src/guile-log/language/prolog/modules/library/clpfd.pl")
((@ (guile) define) *optable-save-first* #t)
((@ (guile) when) *optable-save-first*
((@ (guile) set!) *optable-save-first* #f)
(module-optable-set! (save-operator-table)))
((@ (guile) define) *prolog-scm-path* "./")
((@ (guile) define) *prolog-reverse-path* "../clpfd.pl")
......@@ -16,6 +16,8 @@
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log prolog namespace)
#:use-module (logic guile-log prolog closed)
#:use-module (logic guile-log prolog goal-functors)
#:use-module ((logic guile-log prolog goal-transformers) #:select (*once*))
#:use-module (logic guile-log dynamic-features)
#:use-module (logic guile-log guile-prolog attribute)
#:use-module (logic guile-log guile-prolog dynamic-features)
......@@ -64,6 +66,7 @@
(define empty #t)
(define hash_new #t)
(define vtosym #t)
(define vtosym_ #t)
(define vtosym4 #t)
(mk-sym finish)
......@@ -328,6 +331,11 @@ HELP FOR PROLOG COMMANDS
(namespace-lexical? x))
S))))
(<define> (if_once Y Z)
(if (eq? (<lookup> *once*) S)
(goal-eval Y)
(goal-eval Z)))
(compile-prolog-string
"
leave :- throw(leave).
......@@ -375,7 +383,7 @@ conversation2(X,All) :-
consult(X,V,N,All) :-
do[(fluid-set! -nsol- (<lookup> All))],
catch(((solve(X),output_and_more(V,N)) ; (nl,write(no),nl,fail)),finish,
catch((solve(V,N,X) ; (nl,write(no),nl,fail)),finish,
fail).
vtosym(X,Y) :- make_vhash(H),make_fluid(0,I),rec_analyze(X),vtosym4(X,Y,H,I).
......@@ -405,11 +413,14 @@ hash_new(X,Y,H,I) :-
fluid_set(I,scm[(+ 1 (fluid-ref (<lookup> I)))]),
vhashq_cons(H,X,Y).
output_and_more(V,N) :-
when[(eq? (fluid-ref -mute?-) #t)] -> more ;
(
(V==[] -> (write(\"yes\"),nl) ; (once(vtosym(V,VV)),write_out(VV,N),nl)), more
).
output_and_more(V,N,More) :-
(when[(eq? (fluid-ref -mute?-) #t)] -> more ;
(
(V==[] -> (write(\"yes\"),nl) ; (once(vtosym(V,VV)),
write_out(VV,N),nl)),
(More=#t -> more ; throw(finish))
)
).
write_out([],[]).
write_out([V|Vs],[N|Ns])
......@@ -441,7 +452,9 @@ more :-
empty :- peek_char(X),char_code(X,Code),Code==10->get_char(_);true.
solve(X) :- X.
solve(V,N,X) :- X,
if_once(output_and_more(V,N,#f),output_and_more(V,N,#t)).
.
")
(define recurs-map (make-fluid '()))
......
......@@ -177,11 +177,6 @@
(<define> (set x y) (<set> x y))
(fluid-set!
*prolog-ops*
*swi-standard-operators*)
(define-syntax-rule (re-export-iso-operators)
(re-export ^ op1:- :- #{,}# -> #{\\+}# op2= == =..
#{\\=}# #{\\==}# @< @> @>= @=< is
......
......@@ -40,7 +40,7 @@
var atomic compound nonvar
directive
procedure_name
once
once *once*
-var -atom
halt
......@@ -914,6 +914,8 @@ floor(x) (floor x)
(define p (lambda x #f))
(define ss (fluid-ref *current-stack*))
(define *once* (gp-make-var #t))
(<define> (once-f v)
(<let> ((v (<lookup> v)))
(if (<var?> v)
......@@ -921,6 +923,7 @@ floor(x) (floor x)
(<and>
(<code> (gp-var-set *call-expression* v S))
(goal-eval v)
(<code> (gp-var-set *once* S S))
<cut>))))
(<define-guile-log-rule> (once-mac v) (once-f v))
......@@ -962,6 +965,7 @@ floor(x) (floor x)
(set! (@ (logic guile-log prolog names) !) !)
(set! (@ (logic guile-log prolog names) atom) atom)
(set! (@@ (logic guile-log prolog variant) op2=) op2=)
(set! (@@ (logic guile-log prolog modules) *once*) *once*)
(set! first? #f)))
......
......@@ -3,7 +3,7 @@
#:use-module (logic guile-log prolog goal-functors)
#:use-module (logic guile-log prolog pre)
#:use-module (logic guile-log)
#:use-module ((logic guile-log umatch) #:select (*current-stack*))
#:use-module ((logic guile-log umatch) #:select (*current-stack* gp-var-set))
#:use-module (system base language)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
......@@ -64,6 +64,7 @@
(with-input-from-file fpl
(lambda ()
(prolog-parse-module #f))))
(define module-data (let lp ((l module-data-opdata))
(if (pair? l)
(let ((x (car l)))
......@@ -71,13 +72,14 @@
(cons x (lp (cdr l)))
(lp (cdr l))))
'())))
(define module-opdata (let lp ((l module-data-opdata))
(if (pair? l)
(let ((x (car l)))
(if (and (pair? x) (eq? (car x) #:op))
(cons (cdr x) (lp (cdr l)))
(lp (cdr l))))
'())))
(if (pair? l)
(let ((x (car l)))
(if (and (pair? x) (eq? (car x) #:op))
(cons (cdr x) (lp (cdr l)))
(lp (cdr l))))
'())))
(define (add.. n x)
(if (> n 0)
(add.. (- n 1) (string-append "../" x))
......@@ -101,7 +103,8 @@
(cons* #\\ #\\ (lp (cdr l)))
(cons* x (lp (cdr l)))))
'()))))
(lambda ()
(lambda ()
(define rpl #f)
(let* ((r module-data)
(a.b (let lp ((rpl (string-split fpl #\/))
......@@ -110,7 +113,8 @@
(if (equal? (car rpl) (car rsc))
(lp (cdr rpl) (cdr rsc))
(cons (add.. (length rsc) (string-join rpl "/"))
(string-join rsc "/"))))))
(string-join rsc "/")))
(error "bug in module code"))))
(rpl0 (if (fluid-ref relative-path) (car a.b) fpl))
(rsc (cdr a.b)))
(set! rpl rpl0)
......@@ -122,7 +126,8 @@
#:replace ~a)
" (m path) (map hh (cdr r)))))
(format #t "(clear-directives)~%")
(format #t "(fluid-set! *prolog-ops* *swi-standard-operators*)~%")
(format #t "(eval-when (compile load eval)
(fluid-set! *prolog-ops* *swi-standard-operators*))~%")
(when (pair? module-opdata)
(format #t "(compile-prolog-string \"~%")
......@@ -320,7 +325,7 @@
(let* ((mpl (stat:mtime (stat fpl)))
(mscm (stat:mtime (stat fscm))))
(< (+ mscm 10) mpl)))
(pk `(write-scm ,fscm))
(with-output-to-file fscm
(write-module fpl fscm path))))
......@@ -542,8 +547,13 @@
(cons (car l) (lp (cdr l))))
'())))))
(define *once* #f)
(<define> (use_module . l)
(<apply> use_module_ l)
(<code> (gp-var-set *once* S S)))
(define use_module
(define use_module_
(<case-lambda>
((mod syms)
(<var> (mod2)
......@@ -598,8 +608,8 @@
((a . l)
(<cut>
(<and>
(use_module a)
(use_module l))))
(use_module_ a)
(use_module_ l))))
(()
(<cut> <cc>))
......@@ -627,6 +637,7 @@
(*current-stack* S))
(process-use_module `((,f2)))))))))))))
(define (parse-out-module stx x)
(match x
((#:atom nm . _)
......
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