delay.scm 2.59 KB
Newer Older
1 2
(define-module (logic guile-log guile-prolog delay)
  #:use-module (logic guile-log iso-prolog)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
3
  #:use-module (logic guile-log prolog goal-functors)
4 5
  #:use-module (logic guile-log)
  #:use-module (srfi srfi-9)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
6 7
  #:use-module (srfi srfi-9 gnu)
  #:export (delay_exp force_exp))
8 9

(define-record-type <delay>
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
10
  (make-delay exp var)
11
  delay?
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
12 13
  (exp    delay-exp)
  (var    delay-var))
14 15 16

(set-record-type-printer! <delay>
   (lambda (vl port) 
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
17
     (format port "<delayed>")))
18

19 20 21 22 23 24
(compile-prolog-string 
"
'delay-match'(X,X):-!. 
'delay-match'(X,(A,B)) :- 'delay-match'(X,A) -> true : 'delay-match'(X,B).
")

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
25
(<define> (delay_exp e . l)
26
  (<recur> lp ((l l) (hit? #f))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
27 28 29 30 31 32 33 34 35 36 37 38
    (<<match>> (#:mode -) (l)	   
      (((and x ($ delay?)) . l)
       (<and>
	(lp l #t)))
      ((x . l)
       (<let> ((x (<lookup> x)))
	 (cond
	  ((<var?> x)
	   (<=> x ,(make-delay e x))
	   (lp l #t))
	  ((delay? x)	   
	   (<let> ((ee (delay-exp x)))
39
	     (<if> (delay-match e ee)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
40 41 42 43 44 45 46
		   <cc>
		   (<set> (delay-var x)
			  (make-delay (vector (list #{,}# ee e))
				      (delay-var x))))
	     (lp l #t)))
	  (else
	   (lp l hit?)))))
47 48 49
      (()
       (when hit?)))))

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
50 51 52 53
(<define> (delayed_exp_p x)
  (<let> ((x (<lookup> x)))
    (when (delay? x)
      (<cc> (delay-exp x) (delay-var x)))))
54

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
55 56 57 58 59 60 61 62
(<define> (force_exp var val)
 (<or>
  (<and>
   (<values> (f v) (delayed_exp_p var))
   <cut>
   (<set> v val)
   (goal-eval f))
  (<=> var val)))
63

64
#;
65 66
(compile-prolog-string
"
67
random(N,X,P) :- (get_fail(P), random(N,X)) ; nextRand(N,X,P).
68

69
adjust_window(0,L)     :- L=[]).
70
adjust_window(N,[_|L]) :- NN is N - 1, adjust_window(NN,L).
71
adjust_window(N,[]).
72

73 74 75 76
next_inc(N,NN,NN) :- NN is N + 1.
next_history(L,LL,M,X,LL) :- LL = [X|L], adjust_window(M,LL).
start_inc(_,N,N).
start_history(_,S) :- S=[].
77

78 79 80
mwop(Op, Seed, [A|B] , X) :-
   Op(A,Seed,Z),
   mwop(Op, Z, B, X).
81

82 83 84
mwop(_,X,[],X).
maxx(Z,[X|_],[Y|_])  :- Z is max(X,Y).
  
85

86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120
plusz(X,Z,Y,Z) :- 
   delay_exp(plusz,Z,X,Y) -> true ; 
   (ZZ is X + Y   , force_exp(Z,ZZ)).

% M : x1 x2 x3 x4...  => q1 q2 q3 ...
      q1 = max(x1,x2), q2=max(x1,x2,x3), g3=max(x2,x3,x4) ...
% generera två slumpmässiga l1 l2, s.a. M(l2)>=M(l1), skriv ut M(l1) + M(l2)

start1([[],[],0]).
next1 -->
  {
     random(10,X1), 
     random(10,X2,P) 
  },

  +[
     next_history(3,[X1,V1]  ,LX1),
     next_history(3,[X2,V2,P],LX2),
     plusz(Z,Res)
  ],

  {
    mwop(maxz,0,LX1,M1), 
    mwop(maxz,0,LX2,M2),
    last([_,_,P],LX2),
    length(LX1,1) -> true ;
    ref([_,MM1,_],1,LX1),
    ref([_,MM2,_],1,LX2))
    (M2 < M1 -> fail_it(P) ;  true),
    force_exp(MM1,M1),
    force_exp(MM2,M2),
    plusz(V1,Z,V2,_),
    writez([X1,X2,Z],Res)
  }.
")