dynamic-features.scm 3.24 KB
Newer Older
1
(define-module (logic guile-log guile-prolog dynamic-features)
2 3 4 5
  #:use-module (logic guile-log)
  #:use-module (logic guile-log iso-prolog)
  #:use-module (logic guile-log dynamic-features)
  #:use-module (logic guile-log prolog error)
6 7 8
  #:use-module (logic guile-log prolog parser)
  #:use-module (logic guile-log prolog char-conversion)
  #:use-module (logic guile-log prolog directives)
9 10
  #:use-module (logic guile-log prolog names)
  #:use-module (logic guile-log prolog goal-functors)
11 12 13
  #:re-export (get_prolog_operators_handle
               get_prolog_flags_handle
               get_prolog_conversion_handle)
14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32
  #:export(backtrack_dynamic_object
	   not_backtrack_dynamic_object
	   fluid_guard_dynamic_object
	   state_guard_dynamic_object
	   state_guard_dynamic_object_zip
	   always_state_guard_dynamic_object 

	   with_fluid_guard_dynamic_object
	   with_fluid_guard_dynamic_object_once
	   with_state_guard_dynamic_object
	   with_state_guard_dynamic_object_zip
	   with_always_state_guard_dynamic_object 
	   with_backtrack_dynamic_object
	   with_not_backtrack_dynamic_object

           copy_dynamic_object
           set_dynamic

           dynamic_feature
33 34

	   add_dynamic_feature
35 36 37 38
	   ))

(mk-sym dynamic_feature)

39 40 41 42
(<define> (add_dynamic_feature . l)
  (<recur> lp ((l l))
    (if (pair? l)
	(<and>
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
43
	 (add-dynamic-function-dynamics (<lookup> (car l)))
44 45 46
	 (lp (cdr l)))
	<cc>)))
	
47
(<define> (fail- h) (type_error dynamic_feature h))
48 49 50 51

(define-syntax-rule (mk backtrack_dynamic_object backtrack-dynamic-object)
  (<define> (backtrack_dynamic_object . h)
    (<recur> lp ((h h))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
52 53
      (if (pair? h)
          (<and>
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
54
           (backtrack-dynamic-object (<lookup> (car h)) fail-)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
55 56
           (lp (cdr h)))
          <cc>))))
57 58 59 60 61 62 63 64 65 66 67 68


(mk        backtrack_dynamic_object           backtrack-dynamic-object)
(mk    not_backtrack_dynamic_object       not-backtrack-dynamic-object)
(mk        fluid_guard_dynamic_object         fluid-guard-dynamic-object)
(mk        state_guard_dynamic_object         state-guard-dynamic-object)
(mk always_state_guard_dynamic_object  always-state-guard-dynamic-object)

(define-syntax-rule (mk-with a_b a-b)
  (define a_b
    (<case-lambda>
     ((h code)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
69
      (a-b (<lookup> h) (<lambda> () (goal-eval code)) fail-))
70
     ((h  . l)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
71
      (a-b (<lookup> h) (<lambda> () (<apply> a_b l)) fail-)))))
72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93

(mk-with with_fluid_guard_dynamic_object 
         with-fluid-guard-dynamic-object)

(mk-with with_fluid_guard_dynamic_object_once 
         with-fluid-guard-dynamic-object-once)

(mk-with with_state_guard_dynamic_object
         with-state-guard-dynamic-object)

(mk-with with_state_guard_dynamic_object_zip
         with-state-guard-dynamic-object-zip)

(mk-with with_always_state_guard_dynamic_object 
         with-always-state-guard-dynamic-object)

(mk-with with_backtrack_dynamic_object
         with-backtrack-dynamic-object)

(mk-with with_not_backtrack_dynamic_object
         with-not-backtrack-dynamic-object)

94
(<define> (copy_dynamic_object_ x y) (copy-dynamic-object x y #:fail fail-))
95 96 97 98
(compile-prolog-string 
"
copy_dynamic_object(X->Y) :- copy_dynamic_object_(X,Y).
")
99

100
(<define> (failxy s p cc x y tx ty) (fail- y))          
101
(<define> (set_dynamic_ x y) (set-dynamic x y #:fail fail #:failxy failxy))
102
(compile-prolog-string "set_dynamic(X->Y) :- set_dynamic_(X,Y).")
103