depth-iterated-compressions working (tests fail b/c of compiler makin…

…g transforms on the input)

church/beam-learning.church

@@ -1,4 +1,4 @@
-(define transform-types '(compressions internalize-arguments))
+(define transform-types (list compressions internalize-arguments))
 
 ;;;searches through transformations of the sexpr (uniform-draw (list [observed data here])) , returns a thunk evaluates a uniforml draws over compressed forms of each observation, here data is a list of factor graphs
 (define (learn-model data size-weight score-weight)
@@ -35,9 +35,9 @@
 
 ;;depth-iterated-transformations is only for testing purposes to check if my-iterated-transformations is correct
 (define (depth-iterated-transformations cfilter program depth)
-  (let* ([transformed-programs (if (= depth 0) '() (append (map (lambda (transform-type) (cfilter (transform-type program #t))) transform-types)))])
-    (append transformed-programs
-            (apply append (map (lambda (prog) (depth-iterated-transformations cfilter prog (- depth 1))) transformed-programs)))))
+  (let* ([transformed-programs (if (= depth 0) '() (concatenate (map (lambda (transform-type) (cfilter (transform-type program #t))) transform-types)))])
+    (delete '()  (append transformed-programs
+             (apply append (map (lambda (prog) (depth-iterated-transformations cfilter prog (- depth 1))) transformed-programs))))))
 
 
 (define (best-n n programs data size-weight score-weight)

church/tests/beam-learning-tests.church

@@ -88,14 +88,14 @@
 
 ;;;church-iterated-compressions test
 ;;recursion test
-(program ((abstraction F2 (V2 V3) (V2 (F1 V3))) (abstraction F1 (V1) (node V1))) (F2 F1 1))
+;;(program ((abstraction F2 (V2 V3) (V2 (F1 V3))) (abstraction F1 (V1) (node V1))) (F2 F1 1))
 
-(define timed-iterated-compressions (time-it depth-iterated-compressions "my-iterated-compressions"))
-(let ([compression-programs (map sexpr->program '((let () (define F1 (lambda (V1) (node V1))) (F1 (F1 1))) (let () (define F2 (lambda (V2 V3) (V2 V3))) (define F1 (lambda (V1) (F2 node V1))) (F2 F1 (F2 F1 1))) (let () (define F2 (lambda (V2 V3) (V2 (F1 V3)))) (define F1 (lambda (V1) (node V1))) (F2 F1 1)) (let () (define F2 (lambda (V2) (F1 V2))) (define F1 (lambda (V1) (node V1))) (F2 (F2 1)))))]
-      [argument-internalize-programs (map sexpr->program '((let () (define (F1) (let ([x ((uniform-draw (list (lambda () 1) (lambda () (F1)))))]) (list x)) ) (F1))))])
+(define timed-iterated-compressions (time-it depth-iterated-transformations "my-iterated-compressions"))
+(let* ([compression-programs (map sexpr->program '((let () (define F1 (lambda (V1) (node V1))) (F1 (F1 1))) (let () (define F2 (lambda (V2 V3) (V2 V3))) (define F1 (lambda (V1) (F2 node V1))) (F2 F1 (F2 F1 1))) (let () (define F2 (lambda (V2 V3) (V2 (F1 V3)))) (define F1 (lambda (V1) (node V1))) (F2 F1 1)) (let () (define F2 (lambda (V2) (F1 V2))) (define F1 (lambda (V1) (node V1))) (F2 (F2 1)))))]
+       [argument-internalize-programs (map sexpr->program '((let () (define F1 (lambda () (let ([V1 ((uniform-draw (list (lambda () 1) (lambda () (F1)))))]) (node V1))) ) (F1))))])
   (equal?-test "iterated-compressions internalize-argument test"
                (timed-iterated-compressions (lambda (x) x) (make-program '() '(node (node 1))) 2)
-               (append compressible-programs argument-internalize-programs)))
+               (append compression-programs argument-internalize-programs)))
 
 ;; ;;;beam-learn-search-compressions test
 ;; (define timed-beam-learn-search-compressions (time-it beam-learn-search-compressions "beam-learn-search"))
@@ -130,48 +130,48 @@
 
 ;;;topology scoring test
 ;;in the original policy all numbers treated w/ strict equality
-(set-policy! 'original)
-(let* ([init-py-fg '(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))))))]
-       [scheme-prog (python-format->scheme-program init-py-fg)])
-  (equal?-test "score-fg-program test with new fg format"
-               (exp (score-fg-program scheme-prog '(((((1) (-0.2) (2 0.1) (0 0.1))
-                                                  (((0.8) (-0.1) (3 0.1) (0 0.1)))))) 10))
-               0.0))
-;;for noisy-number the geometry has a threshold for comparison
-(set-policy! 'noisy-number)
-(let* ([init-py-fg '(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))))))]
-       [scheme-prog (python-format->scheme-program init-py-fg)])
-  (equal?-test "score-fg-program test with new fg format"
-               (exp (score-fg-program scheme-prog '(((((1) (-0.2) (2 0.1) (0 0.1))
-                                                  (((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)
-(let* ([init-py-fg '(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))))))]
-       [scheme-prog (python-format->scheme-program init-py-fg)])
-  (equal?-test "score-fg-program test with new fg format"
-               (exp (score-fg-program scheme-prog '(((((0) (0) (0 0) (0 0))
-                                                  (((0) (0) (0 0) (0 0)))))) 10))
-               1.0))
-
-(let* ([init-py-fg '(GN2 
-                     (GN1
-                      (N2 (data (radius 1.2) (blobbiness -0.2) (Distance 2 0.1) (Straightness 0 0.1)))))]
-       [scheme-prog (python-format->scheme-program init-py-fg)])
-  (equal?-test "score-fg-program test with new fg format"
-               (exp (score-fg-program scheme-prog '(((((0) (0) (0 0) (0 0))
-                                                  (((0) (0) (0 0) (0 0)))))) 10))
-               0.0))
+;; (set-policy! 'original)
+;; (let* ([init-py-fg '(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))))))]
+;;        [scheme-prog (python-format->scheme-program init-py-fg)])
+;;   (equal?-test "score-fg-program test with new fg format"
+;;                (exp (score-fg-program scheme-prog '(((((1) (-0.2) (2 0.1) (0 0.1))
+;;                                                   (((0.8) (-0.1) (3 0.1) (0 0.1)))))) 10))
+;;                0.0))
+;; ;;for noisy-number the geometry has a threshold for comparison
+;; (set-policy! 'noisy-number)
+;; (let* ([init-py-fg '(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))))))]
+;;        [scheme-prog (python-format->scheme-program init-py-fg)])
+;;   (equal?-test "score-fg-program test with new fg format"
+;;                (exp (score-fg-program scheme-prog '(((((1) (-0.2) (2 0.1) (0 0.1))
+;;                                                   (((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)
+;; (let* ([init-py-fg '(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))))))]
+;;        [scheme-prog (python-format->scheme-program init-py-fg)])
+;;   (equal?-test "score-fg-program test with new fg format"
+;;                (exp (score-fg-program scheme-prog '(((((0) (0) (0 0) (0 0))
+;;                                                   (((0) (0) (0 0) (0 0)))))) 10))
+;;                1.0))
+
+;; (let* ([init-py-fg '(GN2 
+;;                      (GN1
+;;                       (N2 (data (radius 1.2) (blobbiness -0.2) (Distance 2 0.1) (Straightness 0 0.1)))))]
+;;        [scheme-prog (python-format->scheme-program init-py-fg)])
+;;   (equal?-test "score-fg-program test with new fg format"
+;;                (exp (score-fg-program scheme-prog '(((((0) (0) (0 0) (0 0))
+;;                                                   (((0) (0) (0 0) (0 0)))))) 10))
+;;                0.0))
 
 
 

scheme/abstract.ss

@@ -6,7 +6,7 @@
 ;; - make a test case for getting anonymous functions when inlining
 ;; - inlining with higher-order functions leads to loss of irreducibility through the creation of anonymous functions? rewrite applied lambdas in the body of a program 
 (library (abstract)
-         (export true-compressions all-compressions compressions test-abstraction-proposer abstraction-move sexpr->program proposal beam-search-compressions beam-compression make-program  pretty-print-program program->sexpr size get-abstractions make-abstraction abstraction->define define->abstraction var? func? normalize-names func-symbol all-iterated-compressions iterated-compressions inline unique-programs sort-by-size program->body program->abstraction-applications program->abstractions abstraction->vars abstraction->pattern abstraction->name abstraction->variable-position make-named-abstraction unique-commutative-pairs possible-abstractions find-tagged-symbols set-indices-floor! condense-program replace-matches program->replace-abstraction)
+         (export true-compressions all-compressions compressions test-abstraction-proposer abstraction-move sexpr->program proposal beam-search-compressions beam-compression make-program  pretty-print-program program->sexpr size get-abstractions make-abstraction abstraction->define define->abstraction var? func? normalize-names func-symbol all-iterated-compressions iterated-compressions inline unique-programs sort-by-size program->body program->abstraction-applications program->abstractions abstraction->vars abstraction->pattern abstraction->name abstraction->variable-position make-named-abstraction unique-commutative-pairs possible-abstractions find-tagged-symbols set-indices-floor! condense-program replace-matches program->replace-abstraction internalize-arguments)
          (import (except (rnrs) string-hash string-ci-hash)
                  (only (ikarus) set-car! set-cdr!)
                  (_srfi :1)
@@ -212,7 +212,7 @@
 
 
          ;; data structures & associated functions
-
+;;;~~~~~~~~~~~~~~~~~~code for compressions~~~~~~~~~~~~~~~~~ (not sure if this is the right starting point)
 
          ;;return valid abstractions for any matching subexpressions in expr
          ;;valid abstractions are those without free variables
@@ -330,9 +330,74 @@
                                compressed-programs))])
              valid-compressed-programs))
 
-
-
-
+;;;~~~~~~~~~~~~end code for compressions~~~~~~~~~~~~~~~~~~~~~         
+;;;=========code for internalize-arguments=============================
+         ;;a transformation is performed for each variable of each abstraction 
+         (define (internalize-arguments program . nofilter)
+           (let* ([abstractions-with-variables (filter has-arguments? (program->abstractions program))])
+             (concatenate (map (curry abstraction-internalizations program) abstractions-with-variables))))
+
+         (define (has-arguments? abstraction)
+           (not (null? (abstraction->vars abstraction))))
+
+         ;;return a program transformation is returned for each variable in abstraction
+         (define (abstraction-internalizations program abstraction)
+           (map (curry internalize-argument program abstraction) (abstraction->vars abstraction)))
+
+         ;;rewrite the abstraction to have the variable in the abstraction be a mixture of the values its taken on in the program
+         ;;rewrite applications of the abstraction function in the program to not have the variable
+         (define (internalize-argument program abstraction variable)
+           (let* ([new-abstraction (remove-abstraction-variable program abstraction variable)]
+                  [program-with-new-abstraction (program->replace-abstraction program new-abstraction)]
+                  [new-program (remove-application-argument program-with-new-abstraction abstraction variable)])
+             new-program))
+
+         ;;creates a "mixture" distribution over instances of the variable being removed
+         (define (remove-abstraction-variable program abstraction variable)
+           (let* ([mixture-elements (find-variable-instances program abstraction variable)]
+                  [mixture-sexpr (make-mixture-sexpr mixture-elements)]
+                  [new-pattern `(let ([,variable ,mixture-sexpr]) ,(abstraction->pattern abstraction))]
+                  [new-variables (delete variable (abstraction->vars abstraction))])
+             (make-named-abstraction (abstraction->name abstraction) new-pattern new-variables)))
+
+         (define (find-variable-instances program abstraction variable)
+           (let* ([abstraction-applications (program->abstraction-applications program abstraction)]
+                  [variable-position (abstraction->variable-position abstraction variable)]
+                  [variable-instances (map (curry ith-argument variable-position) abstraction-applications)])
+             variable-instances))
+
+         ;;i+1 because the first element is the function name
+         (define (ith-argument i function-application)
+           (list-ref function-application (+ i 1)))
+
+         (define (remove-ith-argument i function-application)
+           (append (take function-application (+ i 1)) (drop function-application (+ i 2))))
+
+         (define (make-mixture-sexpr mixture-elements)
+           `((uniform-draw (list ,@(map thunkify mixture-elements)))))
+
+         (define (thunkify sexpr) `(lambda () ,sexpr))
+
+
+         ;;rewrite applications of abstraction in program to not have the variable argument 
+         (define (remove-application-argument program abstraction variable)
+           (define (abstraction-application? sexpr)
+              (if (non-empty-list? sexpr)
+                  (equal? (first sexpr) (abstraction->name abstraction))
+                  #f))
+           (define (change-application variable-position application)
+              (remove-ith-argument variable-position application))
+           (let* ([variable-position (abstraction->variable-position abstraction variable)]
+                  [program-sexpr (program->sexpr program)]
+                  [changed-sexpr (sexp-search abstraction-application? (curry change-application variable-position) program-sexpr)]
+                  [new-program (sexpr->program changed-sexpr)])
+             new-program))
+
+         ;;assumes abstractions and only abstractions have name of the form '[FUNC-SYMBOL][Number]
+         (define (application? sexpr)
+           (if (non-empty-list? sexpr)
+               (func? (first sexpr))))         
+;;;=========end code for internalize-arguments========================
          (define (true-compressions program)
            (compressions program))
 

scheme/tests/abstract-tests.ss

@@ -102,6 +102,22 @@
 (let* ([program (sexpr->program '(let () (define F1 (lambda (V1) (node V1))) (F1 (F1 1))))]
        [new-abstraction (make-named-abstraction 'F1 '(let ([V1 ((uniform-draw (list (lambda () (F1 1)) (lambda () 1))))]) (node V1)) '())])
   (check (program->replace-abstraction program new-abstraction) => (make-program (list new-abstraction) '(F1 (F1 1)))))
+
+
+;;;internalize-arguments test
+(let* ([correct-abstraction (make-named-abstraction 'F1 '(let ([V1 ((uniform-draw (list (lambda () (F1)) (lambda () 1))))]) (node V1)) '())]
+         [correct-program (make-program (list correct-abstraction) '(F1))])
+    (check (internalize-arguments (sexpr->program '(let () (define F1 (lambda (V1) (node V1))) (F1 (F1 1)))))
+          =>
+          (list correct-program)))
+
+(let* ([correct-abstraction (make-named-abstraction 'F1 '(let ([V1 ((uniform-draw (list (lambda () (F1)) (lambda () 1))))]) (node V1)) '())]
+         [correct-program (make-program (list correct-abstraction) '(F1))])
+    (check (internalize-arguments (make-program '() '(node (node 1))))
+          =>
+          '()))
+
+
 (check-report)
 ;; (define (test-unify)
 ;;   (let* ([sexpr '(a b c d)]