[racket] Finite State Machines of Arbitrary Size using Racket's composable control

This code was generated in response to the user who sought to implement
run-length encoding of a bit-vector on Sunday night.

I didn't post this to the board b/c there's a much easier way to solve
problem using regular expressions, which Eli B. demonstrated.

But, the (infinite-k-pump) function strikes me as a correct and complete
way to implement finite state machines (FSM) of aribtrary size in racket
using composable control.

Its a toy, but maybe of some pedagogical use.

Jay's web server works essentially the same way, though instead of 
one-byte signals, he's using
http-requests.

Its a good 10 second answer to "what can you do with composable control"
that would be impossible in its absence?

R./
Zack



#lang racket

;Finite State Machine of arbitrary size using composable control


(require racket/control
         rackunit
         rackunit/text-ui)

(define/contract (list-of-ranges-of-ones vtr)
  (-> (vectorof (or/c 1 0)) list?)
  (read (open-input-string (with-output-to-string (λ _
                                                    (display "(")

(encoding-scheme-helper (prompt (infinite-k-pump))

(vector->list (vector-append  vtr #(0))))
                                                    (display ")"))))))

;recursive function. Note the prompt which is how far the invocation of
abort, in (infinite-k-pump) wipes out stack
(define (encoding-scheme-helper kont lst)
  (unless (null? lst)
      (encoding-scheme-helper (prompt (kont (car lst)))
                              (cdr lst))))

(define (infinite-k-pump)
  (let ((counter 0))
    (letrec  ((incr-counter (λ _ (set! counter (add1 counter))))
              (B   (λ (signal)
                       (if
                        (= signal 0)
                        (begin  (display (sub1 counter)) (display ")")
                                (incr-counter)
                                (A (let/cc k (abort k))))
                        (begin (incr-counter)
                               (B (let/cc k (abort k)))))))
              (A   (λ (signal)
                     (if
                      (= signal 0)
                      (begin (incr-counter)
                             (A (let/cc k (abort k))))
                      (begin (display "( ") (display counter) (display " 
")
                             (incr-counter)
                             (B (let/cc k (abort k))))))))
      ;init function is A
      (A (let/cc k (abort k))))))

;(run-tests does-it-work?)
; 12 success(es) 0 failure(s) 0 error(s) 12 test(s) run

(define  does-it-work?
  (test-suite
   "Tests for FSM"
   (check-equal? (list-of-ranges-of-ones #(0)) '())
   (check-equal? (list-of-ranges-of-ones #(0 0))'())
   (check-equal? (list-of-ranges-of-ones #(0 0 0)) '())
   (check-equal? (list-of-ranges-of-ones #(1)) '((0 0)))
   (check-equal? (list-of-ranges-of-ones #(1 1))  '((0 1)))
   (check-equal? (list-of-ranges-of-ones #(1 1 1))  '((0 2)))
   (check-equal? (list-of-ranges-of-ones #(1 1 1 0)) '((0 2)))
   (check-equal? (list-of-ranges-of-ones #(0 1 1 1))  '((1 3)))
   (check-equal? (list-of-ranges-of-ones #(0 1 1 1 0)) '((1 3)))
   (check-equal? (list-of-ranges-of-ones #( 0 1 1 1 0 0 0 1 1 1 0)) '((1 
3)
(7 9)))
   (check-equal? (list-of-ranges-of-ones #( 1 1 1 1 0 0 0 1 1 1 1)) '((0 
3)
(7 10)))
   (check-equal? (list-of-ranges-of-ones #( 0 1 0 1 0 1 0 1 0 1 0)) '((1 
1)
(3 3) (5 5) (7 7) (9 9)))))