starting to get assoc running

parent c91f777f
:- use_module(library(assoc)).
f([(N-N)|X],N) :- N > 0 -> (NN is N - 1, f(X,NN)) ; X=[].
runner1(N,A,S) :- N > 0 -> (get_assoc(N,A,V),
SS is S + V,
NN is N - 1,
runner1(NN,A,SS)) ; (write(res(S)), nl).
do1(N,M,A) :- M > 0 -> (runner1(N,A,0), MM is M - 1, do1(N,MM,A)) ; true.
run1(N,M) :- once((f(L,N), list_to_assoc(L,A), do1(N,M,A))).
(use-modules (logic guile-log iso-prolog))
(use-modules (logic guile-log guile-prolog hash))
(use-modules (logic guile-log guile-prolog ops))
(use-modules (language prolog modules library assoc))
(compile-prolog-string
"
f([(N-N)|X],N) :- N > 0 -> (NN is N - 1, f(X,NN)) ; X=[].
runner1(N,A,S) :- N > 0 -> (get_assoc(N,A,V),
SS is S + V,
NN is N - 1,
runner1(NN,A,SS)) ; (write(res(S)), nl).
runner2(N,A,S) :- N > 0 -> (vhashq_ref(A,N,V),
SS is S + V,
NN is N - 1,
runner2(NN,A,SS)) ; (write(res(S)), nl).
ltoh([],H).
ltoh([K-V|L],H) :- vhashq_cons(H,K,V), ltoh(L,H).
do1(N,M,A) :- M > 0 -> (runner1(N,A,0), MM is M - 1, do1(N,MM,A)) ; true.
do2(N,M,A) :- M > 0 -> (runner2(N,A,0), MM is M - 1, do2(N,MM,A)) ; true.
run1(N,M) :- once((f(L,N), list_to_assoc(L,A), do1(N,M,A))).
run2(N,M) :- once((f(L,N), make_vhash(A), ltoh(L,A), do2(N,M,A))).
")
......@@ -246,6 +246,7 @@
(meta-mk-scheme-op mk-scheme-unop stx nm-code
(x) (tp1) -1-)
; ------------------------------
(define (tr-error op)
(lambda (stx n m . l)
......@@ -362,7 +363,7 @@
#`(<iss> #,(-arg- stx x) #,(scm stx y))))
(_
#`(<iss> #,(-arg- stx x) #,(scm stx y))))))
(define (my-rem x y) (* (remainder x y) y))
(define (my-rem x y) (- x (* (quotient x y) y)))
(define-syntax-rule (shr x y) (ash x (- y)))
(mk-scheme-biop 'yfx "+" tr-+ op2+ .+ s s)
(mk-scheme-biop 'yfx "-" tr-- op2- .- s s)
......@@ -374,7 +375,7 @@
(mk-scheme-biop 'yfx "//" tr-i/ // truncate/ s s)
(mk-scheme-biop 'yfx "rem" tr-rem rem my-rem s s)
(mk-scheme-biop 'yfx "mod" tr-mod mod modulo s s)
(mk-scheme-biop 'yfx "div" tr-div div remainder s s)
(mk-scheme-biop 'yfx "div" tr-div div quotient s s)
(mk-scheme-biop 'xfx "**" tr-pow ** myexpt s s)
(mk-scheme-biop 'xfx "^" tr-pow2 ^ myexpt s s)
(mk-scheme-biop 'yfx "<<" tr-shr << .ash s s)
......@@ -947,6 +948,27 @@ floor(x) (floor x)
(<ret> `(halt ,x))))))
s p cc x))))
(define (name-as f g) (set-procedure-property! f 'name (procedure-name g)))
(name-as gop2- op2-)
(name-as gop2+ op2+)
(name-as gop2- op2-)
(name-as gop1- op1-)
(name-as gop1+ op1+)
(name-as #{g\\}# #{\\}#)
(name-as gop2* op2*)
(name-as gop2/ op2/)
(name-as g// //)
(name-as g** **)
(name-as g<< <<)
(name-as g>> >>)
(name-as #{g/\\}# #{/\\}#)
(name-as #{g\\/}# #{\\/}#)
(name-as gop2< op2<)
(name-as gop2> op2>)
(name-as gop2>= op2>=)
(name-as gop2=< op2=<)
(name-as g=:= =:= )
(name-as #{g=\\=}# #{=\\=}#)
(define first? #t)
(if first?
......
......@@ -205,6 +205,7 @@
(define* (attach-defined-module! f #:optional (mod (current-module)))
(set-procedure-property! f 'module (module-name mod)))
(define* (get-attached-module f #:optional (not-pretty? #t))
(define (st l) (map symbol->string l))
(define mod (procedure-property f 'module))
......
......@@ -44,7 +44,7 @@
(lambda () #f)
(lambda x #t)
keyx keyy)))))))))
(<=> l res))
(<=> l res))
(type_error list x))))
(<define> (sort x l)
......@@ -84,7 +84,7 @@
(<let> ((op (<lookup> op)))
(if (<var?> op)
(<and>
(<or> (<=> op op2<) (<=> op op2>) (<=> op ==))
(<or> (<=> op op2<) (<=> op op2>) (<=> op op2=))
(compare op x y))
(<match> (#:mode -) (op)
(,op2<
......@@ -93,7 +93,7 @@
(,op2>
(<cut>
(term< y x)))
(,==
(,op2=
(<cut>
(<==> x y)))
(_
......
......@@ -1231,7 +1231,12 @@ SCM_DEFINE( smob2scm, "gp->scm", 2, 0, 0, (SCM scm, SCM s),
gp_struct_ref(scm,2),
gp_struct_ref(scm,3));
}
if(SCM_I_IS_VECTOR(scm))
{
SCM l = scm_vector_to_list(scm);
SCM u = smob2scm(l, s);
return scm_vector(u);
}
return scm;
}
}
......
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