learning-sicp

My embarrassing half assed SICP run.
git clone https://kaka.farm/~git/learning-sicp
Log | Files | Refs

exercise-22.scm (1806B)

      1 (define-library (sicp solutions chapter-3 exercise-22)
      2   (import (scheme base))
      3   (import (scheme write))
      4   (export
      5    delete-queue!
      6    empty-queue?
      7    front-queue
      8    insert-queue!
      9    make-queue
     10    print-queue
     11    queue->list
     12    queue->list
     13    )
     14 
     15   (begin
     16     (define (make-queue)
     17       (let ([front-ptr '()]
     18             [rear-ptr '()])
     19 
     20         (define (set-front-ptr! item)
     21           (set! front-ptr item))
     22         (define (set-rear-ptr! item)
     23           (set! rear-ptr item))
     24 
     25         (define (empty-queue?)
     26           (null? front-ptr))
     27 
     28         (define (front-queue)
     29           (if (empty-queue?)
     30               (error "FRONT called with an empty queue" dispatch)
     31               (car front-ptr)))
     32 
     33         (define (insert-queue! item)
     34           (let ([new-pair (cons item '())])
     35             (cond
     36              ((empty-queue?)
     37               (set-front-ptr! new-pair)
     38               (set-rear-ptr! new-pair)
     39               dispatch)
     40              (else
     41               (set-cdr! rear-ptr new-pair)
     42               (set-rear-ptr! new-pair)
     43               dispatch))))
     44 
     45         (define (delete-queue!)
     46           (cond
     47            ((empty-queue?)
     48             (error "DELETE! called with an empty queue" dispatch))
     49            (else
     50             (set-front-ptr! (cdr front-ptr))
     51             dispatch)))
     52 
     53         (define (print-queue . port)
     54           (if (null? port)
     55               (display front-ptr)
     56               (display front-ptr
     57                        (car port))))
     58 
     59         (define (dispatch m)
     60           (cond
     61            ((eq? 'empty? m) empty-queue?)
     62            ((eq? 'front-queue m) front-queue)
     63            ((eq? 'insert-queue! m) insert-queue!)
     64            ((eq? 'delete-queue! m) delete-queue!)
     65            ((eq? 'print-queue m) print-queue)
     66            (else (error "Unknown command: " m))))
     67 
     68         dispatch))))