Merge branch 'sinhayash-master'

mangpo · Nov 28, 2016 · 1f9cd69 · 1f9cd69
2 parents 2db6e38 + f93e48b
commit 1f9cd69
Show file tree

Hide file tree

Showing 133 changed files with 5,742 additions and 4,668 deletions.
diff --git a/GA/GA-enumerator.rkt b/GA/GA-enumerator.rkt
@@ -1,57 +1,36 @@
 #lang racket
 
-(require "../inst.rkt" "../enumerator.rkt")
+(require "../inst.rkt" "../enumerator.rkt" "GA-machine.rkt")
 (require racket/generator)
 
 (provide GA-enumerator%)
 
 (define GA-enumerator%
   (class enumerator%
     (super-new)
-    (init-field machine printer)
-    (override get-flag generate-inst)
-
+    (inherit-field machine)
+
     (define opcodes (get-field opcodes machine))
-    (define arith-inst
-      (map (lambda (x) (vector-member x opcodes)) '(+* 2* 2/ - + and or drop)))
     (define mem-inst
-      (map (lambda (x) (vector-member x opcodes)) '(! !b @ @b)))
-
-    (define-syntax-rule (min-list x) (foldl min (car x) (cdr x)))
-    (define-syntax-rule (max-list x) (foldl max (car x) (cdr x)))
+      (map (lambda (x) (vector-member x opcodes)) '(! !+ !b @ @+ @b)))
 
-    ;; Since we don't use live-in and live-out to prune the search space here, we just return #f for both of them.
-    (define (generate-inst 
-             live-in live-out flag-in flag-out
-             #:no-args [no-args #f] #:try-cmp [try-cmp #f])
-      (define const-range (get-field const-range machine))
-      ;; (define inst-choice '(drop @p b! !b))
-      ;; (define opcode-pool (map (lambda (x) (vector-member x opcodes)) inst-choice))
-      (define opcode-pool (get-field opcode-pool machine))
-      (when no-args
-            (set! opcode-pool
-                  (filter (lambda (x) (member x arith-inst)) opcode-pool)))
-      (when (and flag-in flag-out)
-            (cond
-             [(= (add1 flag-in) (min-list flag-out)) 
-	      (set! opcode-pool (filter (lambda (x) (member x mem-inst)) opcode-pool))]
-             [(< flag-in (min-list flag-out)) (set! opcode-pool (list))]
-             [(> flag-in (max-list flag-out)) (set! opcode-pool (list))]
-             ))
-
-      (generator 
-       ()
-       (for ([opcode-id opcode-pool])
-            (let ([opcode-name (vector-ref opcodes opcode-id)])
-              (cond
-               [(equal? opcode-name `nop) (void)]
-               [(equal? opcode-name `@p)
-                (for ([c const-range])
-                     (yield (list (inst opcode-id c) #f #f)))]
-               [else
-                (yield (list (inst opcode-id #f) #f #f))])))
-       (yield (list #f #f #f))))
+    (define/override (filter-with-pruning-info opcode-pool prune-in prune-out
+                                        #:try-cmp [try-cmp #f] #:no-args [no-args #f])
+      (define-syntax-rule (min-list x) (foldl min (car x) (cdr x)))
+      (define-syntax-rule (max-list x) (foldl max (car x) (cdr x)))
+      (cond
+       [(and prune-in prune-out)
+        (cond
+         [(= (add1 prune-in) (min-list prune-out)) 
+          (filter (lambda (x) (member x mem-inst)) opcode-pool)]
+         [(< prune-in (min-list prune-out)) (list)]
+         [(> prune-in (max-list prune-out)) (list)]
+         [else opcode-pool]
+         )
+        ]
+
+       [else opcode-pool]))
 
-    (define (get-flag state-vec) (length (vector-ref state-vec 9)))
+    (define/override (get-pruning-info state-vec) (get-field index (progstate-comm state-vec)))
 
     ))
diff --git a/GA/GA-forwardbackward.rkt b/GA/GA-forwardbackward.rkt
@@ -1,6 +1,7 @@
 #lang racket
 
 (require "../forwardbackward.rkt" "../inst.rkt" "../ops-racket.rkt"
+         "../special.rkt" "../memory-racket.rkt"
          "GA-machine.rkt")
 
 (require (only-in "GA-simulator-racket.rkt" [GA-simulator-racket% GA-simulator-racket%]))
@@ -13,10 +14,8 @@
     (super-new)
     (inherit-field machine printer)
     (override len-limit window-size
-              mask-in 
               reduce-precision increase-precision reduce-precision-assume
-              change-inst change-inst-list
-	      get-live-mask combine-live prescreen)
+              change-inst change-inst-list)
 
     (define (len-limit) 8)
     (define (window-size) 14)
@@ -29,11 +28,17 @@
     (define RIGHT #x1d5)
     (define IO #x15d)
 
-    (define UP-abst -3)
+    (define UP-abst -2)
     (define DOWN-abst -4)
-    (define LEFT-abst -5)
-    (define RIGHT-abst -6)
-    (define IO-abst -7)
+    (define LEFT-abst -6)
+    (define RIGHT-abst -8)
+    (define IO-abst 6)
+
+    ;; (define UP-abst -3)
+    ;; (define DOWN-abst -4)
+    ;; (define LEFT-abst -5)
+    ;; (define RIGHT-abst -6)
+    ;; (define IO-abst -7)
 
     (define opcodes (get-field opcodes machine))
     (define mask (sub1 (arithmetic-shift 1 bit)))
@@ -42,18 +47,17 @@
     (define (change-inst x change)
       (define opcode-id (inst-op x))
       (define opcode-name (send machine get-opcode-name opcode-id))
-      (define arg (inst-args x))
       (if (equal? opcode-name `@p)
-          (inst opcode-id (change arg))
+          (inst opcode-id (vector-map change (inst-args x)))
           x))
 
     (define (change-inst-list x change)
       (define opcode-id (inst-op x))
       (define opcode-name (send machine get-opcode-name opcode-id))
-      (define arg (inst-args x))
 
       (if (equal? opcode-name `@p)
-          (for/list ([new-arg (change arg)]) (inst opcode-id new-arg))
+          (let ([arg (vector-ref (inst-args x) 0)])
+            (for/list ([new-arg (change arg)]) (inst opcode-id (vector new-arg))))
           (list x)))
 
     (define (reduce-precision prog)
@@ -128,16 +132,19 @@
       (recurse (reverse (for/list ([x prog]) (change-inst-list x change)))
                (list))
       ret)
-
-    (define (get-live-mask state-vec)
-      (define (inner x)
-        (cond
-         [(vector? x) (for/vector ([i x]) (number? i))]
-         [(number? x) #t]
-         [else #f]))
-      (for/vector ([x state-vec]) (inner x)))
 
-    (define (mask-in state-vec live-list #:keep-flag [keep #t])
+    ;; Optional but make performance better much better.
+    ;; Without this, we will never mask-in init states
+    ;; (mask-in init state with 'a' which is always #f in GA
+    ;; because GA:update-live always returns #f)
+    (define/override (combine-live a b)
+      (define s (vector-ref b 3))
+      (define t (vector-ref b 4))
+      (when (and s (not t)) (vector-set! b 4 #t))
+      b)
+
+    ;; Optional but make performance better much better.
+    (define/override (mask-in state-vec live-list #:keep-flag [keep #t])
       (if live-list
           (let* ([pass #t]
                  [ret
@@ -151,59 +158,53 @@
                                  ([i x] [live v] #:break (not pass))
                                  (when (and live (not i)) (set! pass #f))
                                  (and live i))]
-                               [(and (vector? x) (equal? v #f))
-                                (make-vector (vector-length x) #f)]
+                               [(is-a? x memory-racket%)
+                                (if v x (send x clone-init))]
+                               [(is-a? x special%) x]
                                [(equal? v #t)
                                 (unless x (set! pass #f)) x]
                                [else x]))])
-	    (and pass ret))
+            (and pass ret))
           state-vec))
-
-    ;; Ignore a completely.
-    (define (combine-live a b)
-      (define s (vector-ref b 3))
-      (define t (vector-ref b 4))
-      (when (and s (not t)) (vector-set! b 4 #t))
-      b)
 
-    (define (prescreen my-inst state)
-      (define opcode-id (inst-op my-inst))
-      (define a (vector-ref state 0))
-      (define b (vector-ref state 1))
-      (define r (vector-ref state 2))
-      (define s (vector-ref state 3))
-      (define t (vector-ref state 4))
-      (define mem-len (vector-length (vector-ref state 7)))
-
-      (define opcode-name (vector-ref opcodes opcode-id))
-      (define-syntax-rule (inst-eq x) (equal? x opcode-name))
-      (cond
-       [(member opcode-name '(@b))
-        (and b
-             (or (and (>= b 0) (< b mem-len))
-                 (member b (list UP-abst DOWN-abst LEFT-abst RIGHT-abst))))]
-       [(member opcode-name '(!b))
-        (and b t
-             (or (and (>= b 0) (< b mem-len))
-                 (member b (list UP-abst DOWN-abst LEFT-abst RIGHT-abst))))]
-       [(member opcode-name '(@ @+))
-        (and a
-             (or (and (>= a 0) (< a mem-len))
-                 (member a (list UP-abst DOWN-abst LEFT-abst RIGHT-abst))))]
-       [(member opcode-name '(@ @+ ! !+))
-        (and a t
-             (or (and (>= a 0) (< a mem-len))
-                 (member a (list UP-abst DOWN-abst LEFT-abst RIGHT-abst))))]
-       ;; TODO: up down left right for bit = 4
-
-       [(member opcode-name '(+*)) (and a s t)]
-       [(member opcode-name '(2* 2/ - dup push b! a!)) t]
-       [(member opcode-name '(+ and or)) (and s t)]
-       [(member opcode-name '(pop)) r]
-       [(member opcode-name '(over)) s]
-       [(member opcode-name '(a)) a]
-       [else #t]))
-      
+    ;; ;; optional but make performance slightly better.
+    ;; (define/override (prescreen my-inst state)
+    ;;   (define opcode-id (inst-op my-inst))
+    ;;   (define a (progstate-a state))
+    ;;   (define b (progstate-b state))
+    ;;   (define r (progstate-r state))
+    ;;   (define s (progstate-s state))
+    ;;   (define t (progstate-t state))
+    ;;   (define mem-len 64)
+
+    ;;   (define opcode-name (vector-ref opcodes opcode-id))
+    ;;   (define-syntax-rule (inst-eq x) (equal? x opcode-name))
+    ;;   (cond
+    ;;    [(member opcode-name '(@b))
+    ;;     (and b
+    ;;          (or (and (>= b 0) (< b mem-len))
+    ;;              (member b (list UP-abst DOWN-abst LEFT-abst RIGHT-abst))))]
+    ;;    [(member opcode-name '(!b))
+    ;;     (and b t
+    ;;          (or (and (>= b 0) (< b mem-len))
+    ;;              (member b (list UP-abst DOWN-abst LEFT-abst RIGHT-abst))))]
+    ;;    [(member opcode-name '(@ @+))
+    ;;     (and a
+    ;;          (or (and (>= a 0) (< a mem-len))
+    ;;              (member a (list UP-abst DOWN-abst LEFT-abst RIGHT-abst))))]
+    ;;    [(member opcode-name '(! !+))
+    ;;     (and a t
+    ;;          (or (and (>= a 0) (< a mem-len))
+    ;;              (member a (list UP-abst DOWN-abst LEFT-abst RIGHT-abst))))]
+    ;;    ;; TODO: up down left right for bit = 4
+
+    ;;    [(member opcode-name '(+*)) (and a s t)]
+    ;;    [(member opcode-name '(2* 2/ - dup push b! a!)) t]
+    ;;    [(member opcode-name '(+ and or)) (and s t)]
+    ;;    [(member opcode-name '(pop)) r]
+    ;;    [(member opcode-name '(over)) s]
+    ;;    [(member opcode-name '(a)) a]
+    ;;    [else #t]))
 
     ))