Browse files

Now using two different types of thing in alt: alt-delta for changes,…

… alt-event for other things
  • Loading branch information...
pavpanchekha committed Aug 28, 2014
1 parent 917537b commit 050ed1ff8520bd259059e0bbe1565630219cabb3
Showing with 82 additions and 70 deletions.
  1. +39 −11 casio/alternative.rkt
  2. +6 −14 casio/combine-alts.rkt
  3. +1 −1 casio/simplify.rkt
  4. +36 −44 reports/make-graph.rkt
@@ -5,29 +5,54 @@
(require casio/matcher)
(require casio/common)
(provide (struct-out alt) alt-prev make-alt alt-apply alt-rewrite-tree alt-rewrite-expression
alt-errors alt-cost alt-rewrite-rm apply-changes build-alt alt-with-prev
(provide (struct-out alt-delta) (struct-out alt-event)
make-alt alt? alt-program alt-change alt-prev
alt-apply alt-rewrite-tree alt-rewrite-expression
alt-errors alt-cost alt-rewrite-rm apply-changes build-alt alt-set-prev
alt-initial alt-changes alt-history-length)
;; Alts are a lightweight audit trail for Casio.
;; An alt records a low-level view of how Casio got
;; from one program to another.
;; They are a labeled linked list of changes.
(struct alt (program change prevs event)
(struct alt-delta (program change prev)
#:methods gen:custom-write
[(define (write-proc alt port mode)
(display "#<alt " port)
(display "#<alt-delta " port)
(write (alt-program alt) port)
(display ">" port))])
(struct alt-event (program event prevs)
#:methods gen:custom-write
[(define (write-proc alt port mode)
(display "#<alt-event " port)
(write (alt-program alt) port)
(display ">" port))])
(define (make-alt prog)
(alt prog #f '() 'start))
(alt-event prog 'start '()))
(define (alt? altn)
(or (alt-delta? altn) (alt-event? altn)))
(define (alt-program altn)
(match altn
[(alt-delta prog _ _) prog]
[(alt-event prog _ _) prog]))
(define (alt-change altn)
(match altn
[(alt-delta _ cng _) cng]
[(alt-event _ _ '()) #f]
[(alt-event _ _ `(,prev ,_ ...)) (alt-change prev)]))
(define (alt-prev altn)
(match (alt-prevs altn)
[`() #f]
[`(,fst ,_ ...) fst]))
(match altn
[(alt-delta _ _ prev) prev]
[(alt-event _ _ '()) #f]
[(alt-event _ _ `(,prev ,_ ...)) (alt-prev prev)]))
(define (alt-errors altn)
(errors (alt-program altn) (*points*) (*exacts*)))
@@ -36,7 +61,7 @@
(program-cost (alt-program altn)))
(define (alt-apply altn cng)
(alt (change-apply cng (alt-program altn)) cng (list altn) #f))
(alt-delta (change-apply cng (alt-program altn)) cng altn))
;;Applies a list of changes to an alternative.
(define (apply-changes altn changes)
@@ -84,5 +109,8 @@
(+ 1 (alt-history-length (alt-prev alt)))
(define (alt-with-prev prev altn)
(alt (alt-program altn) (alt-change altn) (list prev) #f))
(define (alt-set-prev altn prev)
(alt-delta (alt-program altn) (alt-change altn) prev))
(define (make-regime-alt new-prog altns splitpoints)
(alt-event new-prog (list 'regimes splitpoints) altns))
@@ -115,19 +115,10 @@
[splitpoints* (coerce-indices splitpoints)]
[alts* (recurse-on-alts recurse-func combining-alts splitpoints*)]
[prog-body* (prog-combination splitpoints* alts*)])
(alt `(λ ,(program-variables (alt-program (car alts)))
(make-regime-change (used-alts alts splitpoints) alts* splitpoints* prog-body*)
(used-alts alts splitpoints)
(list 'regimes splitpoints*))))))
(define (make-regime-change orig-alts improved-alts splitpoints final-prog-body)
(let ([new-rule (rule 'regimes 'a final-prog-body '())])
(change new-rule '() (list* '(a . ()) `(splitpoints . ,splitpoints)
(map (λ (orig impr)
`(alt ,orig ,impr))
`(λ ,(program-variables (alt-program (car alts))) ,prog-body*)
(used-alts alts splitpoints)
;; Takes a list of splitpoints, `splitpoints`, whose indices originally referred to some list of alts `alts`,
;; and changes their indices so that they make sense on a list of alts given by `(used-alts alts splitpoints)`.
@@ -297,7 +288,8 @@
(recurse-on-points altns (partition-points splitpoints (*points*) (*exacts*) (length altns))))
(recurse-on-points (for/list ([altn altns]) (alt-event (alt-program altn) 'new-points (list altn)))
(partition-points splitpoints (*points*) (*exacts*) (length altns))))
(define (ulps->bits e)
(if (ordinary-float? e)
@@ -39,7 +39,7 @@
;; We set the prev pointer to null because we only care about the changes we're applying,
;; and we want to make sure to not have red elimination worry about any of the changes
;; before we simplified.
(let* ([stripped-alt (alt-with-prev #f altn)]
(let* ([stripped-alt (alt-set-prev altn #f)]
[simplified-alt (apply-changes stripped-alt unfiltered-changes)]
[re-alt (remove-red (eliminate-dead-head simplified-alt) #:fitness-func reduced? #:aggressive #f)])
(debug "Simplified to " re-alt #:from 'simplify #:depth 2)
@@ -64,50 +64,42 @@
(struct interval (alt-idx start-point end-point vidx))
(define (output-history altn #:stop-at [stop-at #f])
[(and stop-at (equal? (alt-program stop-at) (alt-program altn)))
[(not (alt-change altn))
(printf "<li>Started with <code><pre>~a</pre></code></li>\n"
(pretty-format (alt-program altn) 65))]
[(eq? (rule-name (change-rule (alt-change altn))) 'regimes)
(let* ([vars (change-bindings (alt-change altn))]
[alt-entries (filter (λ (binding) (eq? (car binding) 'alt)) vars)]
[splitpoints (cdr (assoc 'splitpoints vars))])
(let ([intervals (map (λ (start-sp end-sp)
(interval (sp-cidx end-sp)
(sp-point start-sp)
(sp-point end-sp)
(sp-vidx end-sp)))
(cons (sp -1 -1 -inf.0)
(take splitpoints (sub1 (length splitpoints))))
[interval->string (λ (intrvl)
(string-append (number->string (interval-start-point intrvl)) " < "
(symbol->string (list-ref (program-variables (alt-program altn)) (interval-vidx intrvl))) " < "
(number->string (interval-end-point intrvl))))])
(for/list ([entry alt-entries] [entry-idx (range (length alt-entries))])
(let ([applicable-intervals (filter (λ (intrvl)
(= (interval-alt-idx intrvl)
(printf "<h2><code>if <span class='condition'>~a</span></code></h2>\n"
(apply (curry string-append (interval->string (car applicable-intervals)))
(map (λ (i)
(string-append " OR " (interval->string i)))
(cdr applicable-intervals))))
(printf "<ol>\n")
(output-history (second entry))
(printf "<li class='regime-break'></li>\n")
(output-history (third entry) #:stop-at (second entry))
(printf "</ol>\n")))))]
(output-history (alt-prev altn) #:stop-at stop-at)
(printf "<li>Applied <span class='rule'>~a</span> "
(rule-name (change-rule (alt-change altn))))
(printf "to get <code><pre>~a</pre></code></li>\n"
(pretty-format (alt-program altn) 65))]))
(define (output-history altn)
(match altn
[(alt-event _ 'start _)
(printf "<li>Started with <code><pre>~a</pre></code></li>\n"
(pretty-format (alt-program altn) 65))]
[(alt-event prog 'new-points `(,prev))
(output-history prev)
(printf "<li class='regime-break'></li>\n")]
[(alt-event _ `(regimes ,splitpoints) prevs)
(let* ([start-sps (cons (sp -1 -1 -inf.0) (take splitpoints (sub1 (length splitpoints))))]
[vars (program-variables (alt-program altn))]
(for/list ([start-sp start-sps] [end-sp splitpoints])
(interval (sp-cidx end-sp) (sp-point start-sp) (sp-point end-sp) (sp-vidx end-sp)))]
(λ (ival)
(format "~a < ~a < ~a" (interval-start-point ival)
(list-ref vars (interval-vidx ival)) (interval-end-point ival)))])
(for/list ([entry prevs] [entry-idx (range (length prevs))])
(let* ([entry-ivals
(filter (λ (intrvl) (= (interval-alt-idx intrvl) entry-idx)) intervals)]
(string-join (map interval->string entry-ivals) " or ")])
(printf "<h2><code>if <span class='condition'>~a</span></code></h2>\n" condition)
(printf "<ol>\n")
(output-history entry)
(printf "</ol>\n"))))]
[(alt-delta prog cng prev)
(output-history prev)
(printf "<li>Applied <span class='rule'>~a</span> "
(rule-name (change-rule cng)))
(printf "to get <code><pre>~a</pre></code></li>\n"
(pretty-format prog 65))]))
(define (points->pathdata line)

0 comments on commit 050ed1f

Please sign in to comment.