tower-of-hanoi-fp/main.scm

;; PSEUDO-CODE:

;; FUNCTION MoveTower(disk, source, dest, spare):
;; IF disk == 0, THEN:
;;     move disk from source to dest
;; ELSE:
;;     MoveTower(disk - 1, source, spare, dest)   // Step 1 above
;;     move disk from source to dest              // Step 2 above
;;     MoveTower(disk - 1, spare, dest, source)   // Step 3 above
;; END IF

;; This solution for the Towers of Hanoi problem works without modifying any
;; (global) state. This means, that in-between results of steps must be used in
;; the next steps, instead of a globally available game state. This in turn
;; means simply having a reference to each tower from the arguments does not
;; work, because the references are switched around for some calls as well as
;; conceptually for solving the problem recursively. To avoid this problem the
;; solution makes use of tower ids, which are symbols, and finds towers by
;; symbol.

;; The code could be optimized for example by using hashtables for storing the
;; towers, so that a lookup of ids happens in O(1). However, the usual use cases
;; do not force this optimization.

(use-modules (hanoi-model))

(define move-disk
  (λ (hanoi source-id dest-id spare-id)
    (print-hanoi hanoi)
    (display (simple-format #f "moving disk from ~a to ~a\n" source-id dest-id))
    (let ([source-tower (find-tower-by-id hanoi source-id)]
          [dest-tower (find-tower-by-id hanoi dest-id)]
          [spare-tower (find-tower-by-id hanoi spare-id)])
      (create-hanoi
       ;; Remove one disk from the source, because we take it from there and put
       ;; it elsewhere.
       (remove-disk source-tower)
       ;; Since we are directly moving a disk, we do not need the spare, it
       ;; stays the same.
       spare-tower
       ;; Create a new destination tower, to put the disk there.
       (create-tower dest-id
                     (stack-disks (first-of-disks (tower-disks source-tower))
                                  (tower-disks dest-tower)))))))

(define move-tower-disks
  (λ (hanoi disk-size-to-move source-id dest-id spare-id)
    #;(print-hanoi hanoi)
    (cond
     ;; Disk size 1 is the smallest disk size.  If we want to move a disk of
     ;; size 1, we can immediately move it, as it cannot be put onto a smaller
     ;; disk, as there exists no smaller disk.
     [(= disk-size-to-move 1)
      ;; To avoid modification, `move-disk` must return the updated hanoi.
      (move-disk hanoi #|so|# source-id #|de|# dest-id #|sp|# spare-id)]
     [else
      (call-with-values
          (λ ()
            ;; Do 2 preparational steps before moving the largest disk.
            (call-with-values
                (λ ()
                  ;; CASE 1:

                  ;; Move all disks except the lowest one to the spare tower, so
                  ;; that we will be able to move the lowest (largest) disk to
                  ;; the destination afterwards.
                  (move-tower-disks hanoi
                                    (- disk-size-to-move 1)
                                    #|so|# source-id #|de|# spare-id #|sp|# dest-id))
              (λ (updated-hanoi)
                ;; CASE 2:

                ;; Move the largest disk now to the actual destination.
                (move-disk updated-hanoi
                           #|so|# source-id #|de|# dest-id #|sp|# spare-id))))

        (λ (updated-hanoi)
          ;; CASE 3:

          ;; Now we need to move the remaining disks (all except the largest) to
          ;; the destination as well. The remaining disks are at the spare, so
          ;; spare becomes the source. The destination stays the same, so we
          ;; need to use source as spare.
          (move-tower-disks updated-hanoi
                            (- disk-size-to-move 1)
                            #|so|# spare-id #|de|# dest-id #|sp|# source-id)))])))

(define solve-hanoi
  (λ (hanoi)
    (print-hanoi
     (move-tower-disks
      hanoi
      (find-largest-disk (first-of-towers hanoi))
      #|so|# (tower-id (first-tower hanoi))
      #|de|# (tower-id (third-tower hanoi))
      #|sp|# (tower-id  (second-tower hanoi))))))


(solve-hanoi
 (create-hanoi
  (create-tower 'SO '(1 2 3))
  (create-tower 'SP '())
  (create-tower 'DE '())))