code/refunctionalizing_zippers.rkt

   1 #lang racket
   2 (require racket/control)
   3
   4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   5 ;; solutions to the "abSdS" etc task                                   ;;
   6 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   7
   8 ; using a list zipper
   9 (define (tz1 z)
  10   (define (saved z) (car z))
  11   (define (nextchar z) (cadr z))
  12   (define (rest z) (cddr z))
  13   (define pair cons)
  14   (cond
  15     [(null? (cdr z)) (reverse (saved z))]
  16     [(eqv? #\S (nextchar z)) (tz1 (pair (append (saved z) (saved z)) (rest z)))]
  17     [else (tz1 (pair (cons (nextchar z) (saved z)) (rest z)))]))
  18
  19 ; using explicit continuations
  20 (define (tc1 l k)
  21   (cond
  22     [(null? l) (reverse (k '()))]
  23     [(eqv? #\S (car l)) (tc1 (cdr l) (compose k k))]
  24     [else (tc1 (cdr l) (lambda (tail) (cons (car l) (k tail))))]))
  25
  26 ; using implicit continuations (reset/shift)
  27 (define (tr1 l)
  28   (shift k
  29     (cond
  30       [(null? l) (reverse (k '()))]
  31       [(eqv? #\S (car l)) ((compose k k) (tr1 (cdr l)))]
  32       [else ((lambda (tail) (cons (car l) (k tail))) (tr1 (cdr l)))])))
  33
  34 ; wrapper functions, there's a (test) function at the end
  35
  36 (define (tz2 s)
  37   (list->string (tz1 (cons '() (string->list s)))))
  38
  39 (define (tc2 s)
  40   (list->string (tc1 (string->list s) identity)))
  41
  42 (define (tr2 s)
  43   (list->string (reset (tr1 (string->list s)))))
  44
  45 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  46 ;; here are variants that only repeat from S back to the most recent # ;;
  47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  48
  49 ; using a list zipper
  50 (define (tz3 z)
  51   (define (saved z) (car z))
  52   (define (nextchar z) (cadr z))
  53   (define (rest z) (cddr z))
  54   (define (pair x y) (cons x y))
  55   (cond
  56     [(null? (cdr z)) (reverse (saved z))]
  57     [(eqv? #\# (nextchar z)) (append (reverse (saved z)) (tz3 (pair '() (rest z))))]
  58     [(eqv? #\S (nextchar z)) (tz3 (pair (append (saved z) (saved z)) (rest z)))]
  59     [else (tz3 (pair (cons (nextchar z) (saved z)) (rest z)))]))
  60
  61 ; using explicit continuations
  62 ; there are several working solutions
  63 ; but it's a bit tricky to get the reverses in the right place, and the order of appending right
  64 (define (tc3 l k)
  65   (cond
  66     [(null? l) (reverse (k '()))]
  67     [(eqv? #\# (car l)) (append (reverse (k '())) (tc3 (cdr l) identity))]
  68     [(eqv? #\S (car l)) (tc3 (cdr l) (compose k k))]
  69     [else (tc3 (cdr l) (lambda (tail) (cons (car l) (k tail))))]))
  70
  71 ; using implicit continuations (reset/shift)
  72 (define (tr3 l)
  73   (shift k
  74     (cond
  75       [(null? l) (reverse (k '()))]
  76       [(eqv? #\# (car l)) (append (reverse (k '())) (reset (tr3 (cdr l))))]
  77       [(eqv? #\S (car l)) ((compose k k) (tr3 (cdr l)))]
  78       [else ((lambda (tail) (cons (car l) (k tail))) (tr3 (cdr l)))])))
  79
  80 (define (tz4 s)
  81   (list->string (tz3 (cons '() (string->list s)))))
  82
  83 (define (tc4 s)
  84   (list->string (tc3 (string->list s) identity)))
  85
  86 (define (tr4 s)
  87   (list->string (reset (tr3 (string->list s)))))
  88
  89 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  90
  91 (define (test)
  92   (define (cmp t1 t2 inp)
  93     (equal? (t1 inp) (t2 inp)))
  94   (and
  95    (equal? (tz2 "abSd") "ababd")
  96    (cmp tc2 tz2 "abSd")
  97    (cmp tr2 tz2 "abSd")
  98    (equal? (tz2 "aSbS") "aabaab")
  99    (cmp tc2 tz2 "aSbS")
 100    (cmp tr2 tz2 "aSbS")
 101    (equal? (tz4 "ab#ceSfSd") "abcecefcecefd")
 102    (cmp tc4 tz4 "ab#ceSfSd")
 103    (cmp tr4 tz4 "ab#ceSfSd")
 104    (equal? (tz4 "ab#ceS#fSd") "abceceffd")
 105    (cmp tc4 tz4 "ab#ceS#fSd")
 106    (cmp tr4 tz4 "ab#ceS#fSd")
 107    ))