tower-of-hanoi-fp/hanoi-model.scm

(define-module (hanoi-model))

(define-public create-hanoi
  (λ (source spare dest)
    (list source spare dest)))

(define-public rest-of-towers cdr)
(define-public first-of-towers car)

(define-public rest-of-disks cdr)
(define-public first-of-disks car)

(define-public first-tower first-of-towers)
(define-public second-tower (λ (hanoi) (first-of-towers (rest-of-towers hanoi))))
(define-public third-tower (λ (hanoi) (first-of-towers (rest-of-towers (rest-of-towers hanoi)))))

(define-public create-tower
  (λ (id disk-sizes)
    "This is a procedure for creating a tower and assuring, that the tower has a
valid stacking of disks."
    (let check-disk-sizes ([remaining-disks disk-sizes] [previous-disk-size -inf.0])
      (cond
       [(null? remaining-disks) (cons id disk-sizes)]
       [(> (first-of-disks remaining-disks) previous-disk-size)
        (check-disk-sizes (rest-of-disks remaining-disks) (first-of-disks remaining-disks))]
       [else
        (raise (cons 'invalid-disk-placement disk-sizes))]))))

;; A tower shall be a list whose first element is a symbol indicating the tower
;; position.
(define-public tower-disks
  (λ (tower)
    (cdr tower)))

(define-public tower-id
  (λ (tower)
    (car tower)))

(define-public get-tower-basis
  (λ (tower)
    (let loop ([disks (tower-disks tower)])
      (cond
       [(null? disks)
        (error (list 'empty-disks tower))]
       [(null? (rest-of-disks disks))
        (first-of-disks disks)]
       [else
        (loop (rest-of-disks disks))]))))

(define-public find-largest-disk
  (λ (tower)
    (get-tower-basis tower)))

(define-public print-tower
  (λ (id hanoi)
    ((λ (towers)
       (if (not (null? towers))
           (display (simple-format #f "Tower: ~a\n" (first-of-towers towers)))
           (error (list 'tower-id-not-found id hanoi))))
     (filter (λ (tower) (eq? (tower-id tower) id))
             hanoi))))

(define-public print-hanoi
  (λ (hanoi)
    (display (simple-format #f "Towers of Hanoi:\n"))
    (print-tower 'SO hanoi)
    (print-tower 'SP hanoi)
    (print-tower 'DE hanoi)))

(define-public find-tower-by-id
  (λ (hanoi id)
    (cond
     [(null? hanoi)
      (error (list 'tower-id-not-found id hanoi))]
     [(eq? (tower-id (first-of-towers hanoi)) id)
      (first-of-towers hanoi)]
     [else
      (find-tower-by-id (rest-of-towers hanoi) id)])))

(define-public take-disk
  (λ (tower)
    (first-of-disks tower)))

(define-public take-disk-from-tower
  (λ (hanoi id)
    (take-disk (find-tower-by-id hanoi id))))

(define-public remove-disk
  (λ (tower)
    (create-tower (tower-id tower)
                  (rest-of-disks (tower-disks tower)))))

(define-public stack-disks cons)