Skip to content

Commit

Permalink
merge
Browse files Browse the repository at this point in the history
  • Loading branch information
mangpo committed Oct 17, 2016
2 parents 83702b9 + b3ffb16 commit ed96521
Show file tree
Hide file tree
Showing 131 changed files with 5,547 additions and 4,570 deletions.
63 changes: 21 additions & 42 deletions GA/GA-enumerator.rkt
Original file line number Diff line number Diff line change
@@ -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)))

))
137 changes: 69 additions & 68 deletions GA/GA-forwardbackward.rkt
Original file line number Diff line number Diff line change
@@ -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%]))
Expand All @@ -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)
Expand All @@ -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)))
Expand All @@ -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)
Expand Down Expand Up @@ -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
Expand All @@ -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]))

))

Expand Down
Loading

0 comments on commit ed96521

Please sign in to comment.