From f9b64fa2b894ceb0795e4865b6b5f938e9738e81 Mon Sep 17 00:00:00 2001
From: Casey Klein <clklein@racket-lang.org>
Date: Sun, 31 Oct 2010 17:28:19 -0500
Subject: [PATCH] Removes `apply-reduction-relation*' trie experiment

---
 .../redex/private/reduction-semantics.rkt     |   6 +
 collects/redex/trie-experiment/main.rkt       | 139 ------------------
 collects/redex/trie-experiment/run-trace.rkt  |  29 ----
 collects/redex/trie-experiment/sexp-trie.rkt  | 127 ----------------
 4 files changed, 6 insertions(+), 295 deletions(-)
 delete mode 100644 collects/redex/trie-experiment/main.rkt
 delete mode 100644 collects/redex/trie-experiment/run-trace.rkt
 delete mode 100644 collects/redex/trie-experiment/sexp-trie.rkt

diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt
index 8c615bd46f..6acb4a36a2 100644
--- a/collects/redex/private/reduction-semantics.rkt
+++ b/collects/redex/private/reduction-semantics.rkt
@@ -2058,6 +2058,12 @@
           [cycle? #f]
           [cutoff? #f])
       (let loop ([term start]
+                 ;; It would be better to record all visited terms, to avoid traversing
+                 ;; any part of the graph multiple times. Results from 
+                 ;;    collects/redex/trie-experiment
+                 ;; in commit
+                 ;;    152084d5ce6ef49df3ec25c18e40069950146041
+                 ;; suggest that a hash works better than a trie.
                  [path (make-immutable-hash '())]
                  [more-steps steps])
         (if (and goal? (goal? term))
diff --git a/collects/redex/trie-experiment/main.rkt b/collects/redex/trie-experiment/main.rkt
deleted file mode 100644
index f098b57aed..0000000000
--- a/collects/redex/trie-experiment/main.rkt
+++ /dev/null
@@ -1,139 +0,0 @@
-#lang racket
-
-(require (only-in redex/examples/racket-machine/reduction -> load)
-         (only-in redex/examples/racket-machine/model-impl compile-bytecode impl->model)
-         "sexp-trie.rkt"
-         redex/reduction-semantics
-         rackunit)
-
-(define capture-trace #f)
-(define program-size 2)
-(command-line
- #:once-each
- ["--capture-trace" trace-path
-                    "Writes the terms inserted and looked up to the given path"
-                    (set! capture-trace trace-path)]
- ["--program-size" n "The length of the list processed by the bytecode program"
-                   (set! program-size (string->number n))]
- #:args () (void))
-
-(define ((make-eval normal-forms) expr [cycles '()])
-  (map (match-lambda
-         [`((clos ,_) ,_ ,_ ,_ ()) (closure)]
-         [`(,v ,_ ,_ ,_ ()) v]
-         [`(,_ ,_ ,_ ,_ (,_ ,_ ...)) (stuck)]
-         ['error (error)])
-       (normal-forms (program expr cycles))))
-
-(define (show-memory)
-  (collect-garbage)
-  (collect-garbage)
-  (printf "~s MB\n" (exact->inexact (/ (current-memory-use) (expt 2 20)))))
-
-(define eval-hash
-  (make-eval 
-   (λ (p)
-     (let* ([seen (make-hash)]
-            [finals '()]
-            [go (λ (trace)
-                  (time
-                   (let loop ([state p])
-                     (when trace (write (cons 'lookup state) trace))
-                     (unless (hash-ref seen state #f)
-                       (when trace (write (cons 'insert state) trace))
-                       (hash-set! seen state #t)
-                       (let ([succs (apply-reduction-relation -> state)])
-                         (if (null? succs)
-                             (set! finals (cons state finals))
-                             (map loop succs)))))))])
-       (if capture-trace
-           (call-with-output-file #:exists 'truncate capture-trace go)
-           (go #f))
-       (show-memory)
-       (fprintf (open-output-nowhere) "~s" seen)
-       finals))))
-
-(define trie-friendly
-  (match-lambda
-    [(list V S H T C)
-     (list T (reverse H) (reverse C) (reverse S) V)]
-    [x x]))
-
-(define eval-trie
-  (make-eval
-   (λ (p)
-     (let ([seen empty-sexp-trie]
-           [finals '()])
-       (time 
-        (let loop ([state p])
-          (define swapped (trie-friendly state))
-          (unless (lookup swapped seen)
-            (set! seen (insert swapped #t seen))
-            (let ([succs (apply-reduction-relation -> state)])
-              (if (null? succs)
-                  (set! finals (cons state finals))
-                  (map loop succs))))))
-       (show-memory)
-       (fprintf (open-output-nowhere) "~s" seen)
-       finals))))
-
-;; eval: e ((x e) ...) -> (listof result)
-;; Evaluates a bytecode program.
-;; result ::= v | closure | stuck
-(define eval eval-hash)
-
-(define (program expr cycles)
-  (term (load ,expr ,cycles)))
-
-(struct closure () #:transparent)
-(struct stuck () #:transparent)
-(struct error () #:transparent)
-
-;; racket->bytecode: syntax -> (e ((x e) ...))
-;; Compiles a Racket expression into bytecode.
-(define racket->bytecode
-  ;; make sure compilation doesn't insert unhandled debugging stuff
-  (compose impl->model compile-bytecode))
-
-(define a-racket-program
-  #`(let ([cons (λ (x y) (λ (s) (s x y)))]
-          [car (λ (p) (p (λ (x y) x)))]
-          [cdr (λ (p) (p (λ (x y) y)))]
-          [null #f]
-          [null? (λ (x) (if x #f #t))])
-      (letrec ([find (lambda (it? xs)
-                       (if (null? xs)
-                           #f
-                           (let ([x (car xs)])
-                             (if (it? x)
-                                 x
-                                 (find it? (cdr xs))))))])
-        (find (λ (x) x) #,(let loop ([n program-size] [tail #'(cons 1 (cons 2 null))])
-                            (if (zero? n)
-                                tail
-                                (loop (sub1 n) #`(cons #f #,tail))))))))
-
-(match-let ([(cons expr cycles) (racket->bytecode a-racket-program)])
-  ;; Warm Redex's caches
-  (parameterize ([current-output-port (open-output-nowhere)])
-    (eval-hash expr cycles))
-  
-  (unless capture-trace
-    (printf "Begin: ")
-    (show-memory)
-    (newline)
-    
-    (printf "Hash: ")
-    (eval-hash expr cycles)
-    (newline)
-    
-    (printf "Between: ")
-    (show-memory)
-    (newline)
-    
-    (printf "Trie: ")
-    (eval-trie expr cycles)
-    (newline)
-    
-    (printf "End: ")
-    (show-memory)))
diff --git a/collects/redex/trie-experiment/run-trace.rkt b/collects/redex/trie-experiment/run-trace.rkt
deleted file mode 100644
index 008984b8d8..0000000000
--- a/collects/redex/trie-experiment/run-trace.rkt
+++ /dev/null
@@ -1,29 +0,0 @@
-#lang racket
-
-(require "sexp-trie.rkt")
-
-(define trace-path
-  (command-line #:args (path) path))
-
-(define (time-trace insert lookup empty)
-  (call-with-input-file trace-path
-    (λ (trace)
-      (time
-       (let loop ([set empty])
-        (match (read trace)
-          [(? eof-object?)
-           (void)]
-          [(cons 'lookup t)
-           (begin
-             (lookup t set)
-             (loop set))]
-          [(cons 'insert t)
-           (loop (insert t set))]))))))
-
-(printf "Hash\n")
-(time-trace (λ (t s) (hash-set! s t #t) s)
-            (λ (t s) (hash-ref s t #f))
-            (make-hash))
-
-(printf "Trie\n")
-(time-trace (λ (t s) (insert t #t s)) lookup empty-sexp-trie)
\ No newline at end of file
diff --git a/collects/redex/trie-experiment/sexp-trie.rkt b/collects/redex/trie-experiment/sexp-trie.rkt
deleted file mode 100644
index b8e8e02d4c..0000000000
--- a/collects/redex/trie-experiment/sexp-trie.rkt
+++ /dev/null
@@ -1,127 +0,0 @@
-#lang racket
-
-(require rackunit)
-
-(provide empty-sexp-trie
-         lookup
-         insert
-         atom-map-histo)
-
-(struct sexp-trie (atoms   ; (dict/c any α)
-                   lists) #:transparent) ; (or/c (sexp-list-trie α) #f)
-
-(struct sexp-list-trie (empty       ; (or/c #f α)
-                        non-empty) #:transparent) ; (sexp-trie (sexp-list-trie α))
-
-;; empty-sexp-trie: sexp-trie α
-(define empty-sexp-trie (sexp-trie '() #f))
-
-;; lookup: sexp (sexp-trie α) -> (or/c #f α)
-(define (lookup s t)
-  (if (list? s)
-      (and (sexp-trie-lists t)
-           (lookup-list s (sexp-trie-lists t)))
-      (dict-ref (sexp-trie-atoms t) s #f)))
-
-;; lookup-list: (listof sexp) (sexp-list-trie α) -> (or/c #f α)
-(define (lookup-list ss t)
-  (match ss
-    ['() (sexp-list-trie-empty t)]
-    [(cons s ss’)
-     (match (lookup s (sexp-list-trie-non-empty t))
-       [#f #f]
-       [t’ (lookup-list ss’ t’)])]))
-
-;; replace: sexp (α -> α) (sexp-trie α) -> (sexp-trie α)
-(define (replace s f t)
-  (let ([t (or t empty-sexp-trie)])
-    (if (list? s)
-        (let ([t’ (or (sexp-trie-lists t)
-                      (sexp-list-trie #f empty-sexp-trie))])
-          (sexp-trie (sexp-trie-atoms t)
-                     (replace-list s f t’)))
-        (sexp-trie (dict-set (sexp-trie-atoms t) s
-                             (f (dict-ref (sexp-trie-atoms t) s #f)))
-                   (sexp-trie-lists t)))))
-
-;; replace-list: (listof sexp) (α -> α) (sexp-list-trie α) -> (sexp-list-trie α)
-(define (replace-list ss f t) 
-  (match ss
-    ['() 
-     (sexp-list-trie 
-      (f (sexp-list-trie-empty t))
-      (sexp-list-trie-non-empty t))]
-    [(cons s ss’)
-     (sexp-list-trie
-      (sexp-list-trie-empty t)
-      (replace 
-       s
-       (λ (t’) (replace-list ss’ f (or t’ (sexp-list-trie #f empty-sexp-trie))))
-       (sexp-list-trie-non-empty t)))]))
-
-;; insert: sexp α (sexp-trie α) -> (sexp-trie α)
-(define (insert s v t) (replace s (λ (_) v) t))
-
-(define-syntax (test-insert-lookup stx)
-  (syntax-case stx ()
-    [(_ (insertions ...) (lookups ...))
-     (with-syntax ([(checks ...)
-                    (for/list ([lookup-stx (syntax->list #'(lookups ...))])
-                      (with-syntax ([(k . v) lookup-stx])
-                        (syntax/loc lookup-stx
-                          (check-equal? (lookup 'k t) 'v))))])
-       #'(let ([t (for/fold ([t empty-sexp-trie]) ([i '(insertions ...)])
-                    (insert (car i) (cdr i) t))])
-           checks ...))]))
-
-(define-syntax-rule (test-inserted insertions)
-  (test-insert-lookup insertions insertions))
-
-(test-insert-lookup () ((a . #f)))
-(test-insert-lookup ((a . 1))
-                    ((a . 1) (b . #f)))
-(test-inserted ((a . 1) (b . 2)))
-(test-insert-lookup ((a . 1) ((b) . 2))
-                    ((a . 1) ((b) . 2)))
-(test-insert-lookup (((b) . 2) (a . 1))
-                    ((a . 1) ((b) . 2)))
-(test-inserted (((a b c) . 1) 
-                ((a b d) . 2)
-                ((a b c d) . 3)))
-(test-insert-lookup (((a b c) . 1))
-                    (((a b) . #f)))
-(test-inserted (((((a))) . 1)))
-(test-inserted (((a) . 1) ((b) . 1)))
-(test-insert-lookup () ((() . #f)))
-(test-inserted ((a . 1) (() . 2) ((a) . 3)))
-(test-inserted ((() . 2) ((a) . 3)))
-(test-inserted ((a . 1) ((a) . 3) (() . 2)))
-(test-inserted (((a) . 3) (() . 2)))
-(test-inserted (((a) . 1) ((b) . 2)))
-(test-inserted (((a b) . 1) ((a c) . 2)))
-
-; atom-map-histo: (sexp-trie α) -> (listof (cons/c nat/c nat/c))
-(define (atom-map-histo t)
-  (define h (make-hash))
-  (for ([c (let counts ([t t])
-             (match t
-               [(sexp-trie as l)
-                (for/fold ([cs (cons (length as) (counts l))]) ([a as])
-                          (match-let ([(cons _ x) a])
-                            (cond [(sexp-list-trie? x)
-                                   (append (counts x) cs)]
-                                  [else cs])))]
-               [(sexp-list-trie e n)
-                (append (counts e) (counts n))]
-               [_ '()]))])
-       (hash-update! h c add1 0))
-  (sort (hash-map h cons) <= #:key car))
-
-(check-equal?
- (atom-map-histo
-  (insert '(c d) #t (insert '(b) #t (insert 'a #t empty-sexp-trie))))
- '((0 . 2) (1 . 2) (2 . 1)))
-
-(check-equal?
- (atom-map-histo (insert '(() a) 1 empty-sexp-trie))
- '((0 . 4) (1 . 1)))
\ No newline at end of file