modified lazy-equal to take an optional argument that is an equality …

…function, need more testing

church/beam-learning.church

@@ -89,15 +89,16 @@
    (lambda (sexpr data popsize)
      (let ([prog (eval sexpr)])
        (let* ([lazified-data (list->lazy-list data)]
-              (samples (smc-core (map list (iota (+ 1 (lazy-list-size  lazified-data)))) popsize 0
+              (samples (smc-core (map list (iota (+ 1 (lazy-list-size  lazified-data)))) popsize 20
                                  (lambda (depth) (lambda () (let ((s (prog)))
                                                               (pair (lazy-equal? s lazified-data depth)
                                                                     (lambda () (first (lazy-list->list s depth)))))))))
               ;;remove duplicates in order to do selective model averaging:
               ;;find symbol for repeat function and delete (temporary fix)
               (repeat-symbol (find-repeat-symbol samples))
+              [db (pretty-print (list "before selection" (map mcmc-state->query-value samples)))]
               (samples (fold (lambda (s a) (if (member (mcmc-state->addrval s repeat-symbol) (map (lambda (x) (mcmc-state->addrval x repeat-symbol)) a)) a (pair s a))) '() samples))
-
+              [db (pretty-print (list "after selection" (length samples)))]
               (scores (map mcmc-state->score samples))
               (score (if (null? scores)
                          -inf.0
@@ -167,7 +168,6 @@
 
 ;;;estimates p(images|program) ~= \frac{1}{R}\sum_{fg_r ~ p(fg|fg_top)}p(images|fg)p(fg_top|prog) where R is the number of samples
 ;;;this is an importance sampler where the target distribution generates factor graphs based on topology extracted from the images
-
 ;; (define (topology-sampler data prog sample-size)
 ;;   (let* ([none (set-policy! 'topology-only)]
 ;;          [fg-top (imgs->fg_top data)]

church/tests/beam-learning-tests.church

@@ -89,24 +89,21 @@
 ;;;church-iterated-compressions test
 ;;recursion test
 
-
-
-
-(define timed-iterated-compressions (time-it depth-iterated-transformations "my-iterated-compressions"))
-(let* ([abstraction1 (make-named-abstraction 'F1 '(node V1) '(V1))]
-       [program1 (make-program (list abstraction1) '(F1 (F1 1)))]
-       [abstraction21 (make-named-abstraction 'F2 '(V2 V3) '(V2 V3))]
-       [abstraction22 (make-named-abstraction 'F1 '(F2 node V1) '(V1))]
-       [program2 (make-program (list abstraction21 abstraction22) '(F2 F1 (F2 F1 1)))]
-       [abstraction3 (make-named-abstraction 'F2 '(V2 (F1 V3)) '(V2 V3))]
-       [program3 (make-program (list abstraction3 abstraction1) '(F2 F1 1))]
-       [abstraction4 (make-named-abstraction 'F2 '(F1 V2) '(V2))]
-       [program4 (make-program (list abstraction4 abstraction1) '(F2 (F2 1)))]
-       [abstraction5 (make-named-abstraction 'F1 '(let ([V1 ((uniform-draw (list (lambda () (F1)) (lambda () 1))))]) (node V1)) '())]
-       [program5 (make-program (list abstraction5) '(F1))])
-  (equal?-test "iterated-compressions internalize-argument test"
-               (timed-iterated-compressions (lambda (x) x) (make-program '() '(node (node 1))) 2)
-               (list program1 program2 program3 program4 program5)))
+;; (define timed-iterated-compressions (time-it depth-iterated-transformations "my-iterated-compressions"))
+;; (let* ([abstraction1 (make-named-abstraction 'F1 '(node V1) '(V1))]
+;;        [program1 (make-program (list abstraction1) '(F1 (F1 1)))]
+;;        [abstraction21 (make-named-abstraction 'F2 '(V2 V3) '(V2 V3))]
+;;        [abstraction22 (make-named-abstraction 'F1 '(F2 node V1) '(V1))]
+;;        [program2 (make-program (list abstraction21 abstraction22) '(F2 F1 (F2 F1 1)))]
+;;        [abstraction3 (make-named-abstraction 'F2 '(V2 (F1 V3)) '(V2 V3))]
+;;        [program3 (make-program (list abstraction3 abstraction1) '(F2 F1 1))]
+;;        [abstraction4 (make-named-abstraction 'F2 '(F1 V2) '(V2))]
+;;        [program4 (make-program (list abstraction4 abstraction1) '(F2 (F2 1)))]
+;;        [abstraction5 (make-named-abstraction 'F1 '(let ([V1 ((uniform-draw (list (lambda () (F1)) (lambda () 1))))]) (node V1)) '())]
+;;        [program5 (make-program (list abstraction5) '(F1))])
+;;   (equal?-test "iterated-compressions internalize-argument test"
+;;                (timed-iterated-compressions (lambda (x) x) (make-program '() '(node (node 1))) 2)
+;;                (list program1 program2 program3 program4 program5)))
 
 ;; ;;;beam-learn-search-compressions test
 ;; (define timed-beam-learn-search-compressions (time-it beam-learn-search-compressions "beam-learn-search"))
@@ -163,8 +160,8 @@
 ;;                                                   (((0.8) (-0.1) (3 0.1) (0 0.1)))))) 10))
 ;;                1.0))
 
-;; ;;for topology-only the geometry has no effect on matching
-;; (set-policy! 'topology-only)
+;;for topology-only the geometry has no effect on matching
+(set-policy! 'topology-only)
 ;; (let* ([init-py-fg '(GN2 
 ;;                      (GN1
 ;;                       (N2 (data (radius 1.2) (blobbiness -0.2) (Distance 2 0.1) (Straightness 0 0.1))
@@ -184,6 +181,21 @@
 ;;                                                   (((0) (0) (0 0) (0 0)))))) 10))
 ;;                0.0))
 
-
+(let* ([single-node-program (python-format->scheme-program '(GN2 
+                                                        (GN1
+                                                         (N2 (data (radius 1.2) (blobbiness -0.2) (Distance 2 0.1) (Straightness 0 0.1))))))]
+       [double-node-program1 (python-format->scheme-program '(GN2 
+                                                              (GN1
+                                                               (N2 (data (radius 1.2) (blobbiness -0.2) (Distance 2 0.1) (Straightness 0 0.1))
+                                                                   (N1 (data (radius 0.8) (blobbiness -0.1) (Distance 3 0.1) (Straightness 0 0.1)))))))]
+       [double-node-program2 (python-format->scheme-program '(GN2 
+                                                              (GN1
+                                                               (N2 (data (radius 1) (blobbiness -0.2) (Distance 2 0.1) (Straightness 0 0.1))
+                                                                   (N1 (data (radius 0.8) (blobbiness -0.1) (Distance 3 0.1) (Straightness 0 0.1)))))))]
+       [program (list 'lambda '() (list (list 'uniform-draw (list 'list single-node-program double-node-program1 double-node-program2))))])
+  (equal?-test "score-fg-program w/ program that can produce different topologies"
+               (exp (score-fg-program program '(((((0) (0) (0 0) (0 0))
+                                                  (((0) (0) (0 0) (0 0)))))) 10))
+               (/ 2.0 3)))
 
 (exit)

scheme/lazy.ss

@@ -1,7 +1,7 @@
 #!r6rs
 ;;lazy functions
 (library (lazy)
-         (export lazy-list lazy-pair? lazy-pair lazy-equal? lazy-list->list list->lazy-list lazy-null? lazy-append lazy-null lazy-length compute-depth lazy-list->all-list lazy-remove lazy-repeat lazy-map lazy-first lazy-rest lazy-list-size set-policy!)
+         (export lazy-list lazy-pair? lazy-pair lazy-equal? lazy-list->list list->lazy-list lazy-null? lazy-append lazy-null lazy-length compute-depth lazy-list->all-list lazy-remove lazy-repeat lazy-map lazy-first lazy-rest lazy-list-size)
          (import (rnrs)
                  (util)
                  (noisy-number)
@@ -16,46 +16,47 @@
          (define (lazy-pair? a) (if (procedure? a) (eq? 'lazy-pair (a 'type?)) false))
 
          (define lazy-list (lambda args (if (pair? args) (lazy-pair (first args) (apply lazy-list (rest args))) args)))
-         (define policy 'topology-only)
-         (define (set-policy! new-policy)
-           (set! policy new-policy))
-
-         (define (eq-policy)
-           (cond [(eq? policy 'original) eq?]
-                 [(eq? policy 'noisy-number) noisy-number-eq?]
-                 [(eq? policy 'topology-only) topology-only-eq?]
-                 [else (error "eq-policy not handled in lazy-equal!")]))
-
-         (define (topology-only-eq? a b)
-           (if (and (number? a) (number? b)) ;;just do (number? a) rather than (and (number? a) (number? b))
-               #t
-               (eq? a b)))
 
 
          ;;returns false if finds missmatch, otherwise returns amount of sexprs matched.
-         (define (seq-sexpr-equal? t1 t2 depth)
+         (define (seq-sexpr-equal? t1 t2 depth eq-policy)
            (if (= depth 0)
                0
                (if (and (lazy-pair? t1) (lazy-pair? t2))
-                   (let ((left (seq-sexpr-equal? (t1 'first) (t2 'first) (- depth 1))))
+                   (let ((left (seq-sexpr-equal? (t1 'first) (t2 'first) (- depth 1) eq-policy)))
                      (if (eq? false left)
                          false
-                         (seq-sexpr-equal? (t1 'rest) (t2 'rest) left)))
-                   (if ((eq-policy) t1 t2)
+                         (seq-sexpr-equal? (t1 'rest) (t2 'rest) left eq-policy)))
+                   (if (eq-policy t1 t2)
                        (- depth 1)
                        false))))
 
-         (define (sexpr-equal? t1 t2)
+         (define (sexpr-equal? t1 t2 eq-policy)
            (if (and (lazy-pair? t1) (lazy-pair? t2))
-               (and (sexpr-equal? (t1 'first) (t2 'first))
-                    (sexpr-equal? (t1 'rest) (t2 'rest)))
-               ((eq-policy) t1 t2)))
-
-         (define (lazy-equal? a b . depth)
-           (if (null? depth)
-               (sexpr-equal? a b)
-               (not (eq? false (seq-sexpr-equal? a b (first depth))))))
-
+               (and (sexpr-equal? (t1 'first) (t2 'first) eq-policy)
+                    (sexpr-equal? (t1 'rest) (t2 'rest) eq-policy))
+               (eq-policy t1 t2)))
+
+         ;;opt-args can be depth/depth equal function/equal function
+         (define (lazy-equal? a b . opt-args)
+           (let ([depth (parse-opt-depth opt-args)]
+                 [eq-policy (parse-opt-equality opt-args)])
+            (if (null? depth)
+                (sexpr-equal? a b eq-policy)
+                (not (eq? false (seq-sexpr-equal? a b depth eq-policy))))))
+
+         ;;assumes if an equality function was passed in it was the second argument
+         (define (parse-opt-equality opt-args)
+           (cond [(null? opt-args) equal?]
+                 [(and (= (length opt-args) 1) (number? (first opt-args))) equal?]
+                 [(= (length opt-args) 1) (first opt-args)]
+                 [else (second opt-args)]))
+
+         ;;assumes if a depth is passed it is the first argument
+         (define (parse-opt-depth opt-args)
+           (cond [(null? opt-args) opt-args]
+                 [(number? (first opt-args)) (first opt-args)]
+                 [else '()]))
 
 
          (define (lazy-all-equal? lazy-lst1 lazy-lst2)

scheme/tests/lazy-tests.ss

@@ -2,14 +2,15 @@
 (import (rnrs)
         (lazy)
         (church readable-scheme)
+        (noisy-number)
         (srfi :78 lightweight-testing))
 
 ;;;lazy-equal with different policy tests
-(set-policy! 'original)
+
 (check (lazy-equal? (lazy-list 'a 20 300) (lazy-list 'a 20 300)) => #t)
 (check (lazy-equal? (lazy-list 'a 19 300) (lazy-list 'a 20 300)) => #f)
-(set-policy! 'noisy-number)
-(check (lazy-equal? (lazy-list 'a 19 300) (lazy-list 'a 20 300)) => #t)
-(check (lazy-equal? (lazy-list 'a 19 30) (lazy-list 'a 20 300)) => #f)
+
+(check (lazy-equal? (lazy-list 'a 19 300) (lazy-list 'a 20 300) noisy-number-eq?) => #t)
+(check (lazy-equal? (lazy-list 'a 19 30) (lazy-list 'a 20 300) noisy-number-eq?) => #f)
 
 (check-report)