prescheme-demo/lib/ps-grid.scm

;;; ps-grid --- An ASCII grid for Pre-Scheme

(define-record-type grid :grid
  (%make-grid width height size front-buffer back-buffer)
  (width integer grid-width)
  (height integer grid-height)
  (size integer grid-size)
  (front-buffer (^ char) grid-front-buffer %set-grid-front-buffer!)
  (back-buffer (^ char) grid-back-buffer %set-grid-back-buffer!))

(define (create-grid width height)
  (let* ((size (* width height))
         (front (make-vector size #\nul))
         (back (make-vector size #\nul)))
    (%make-grid width height size front back)))

(define (destroy-grid grid)
  (deallocate (grid-front-buffer grid))
  (deallocate (grid-back-buffer grid))
  (deallocate grid))

(define (grid-buffer-ref grid ix)
  (char->ascii (vector-ref (grid-front-buffer grid) ix)))

(define (grid-buffer-set! grid ix value)
  (vector-set! (grid-back-buffer grid) ix (ascii->char value)))

(define (grid-buffer-swap! grid)
  (let ((tmp (grid-front-buffer grid)))
    (%set-grid-front-buffer! grid (grid-back-buffer grid))
    (%set-grid-back-buffer! grid tmp)))

(define (wrap n m)
  (let ((rem (remainder n m)))
    (if (< rem 0)
        (+ rem m)
        rem)))

(define (grid-index grid x y)
  (let ((x (wrap x (grid-width grid)))
        (y (wrap y (grid-height grid))))
    (+ x (* y (grid-width grid)))))

(define (grid-ref grid x y)
  (grid-buffer-ref grid (grid-index grid x y)))

(define (grid-fold proc grid init)
  (let ((width (grid-width grid))
        (height (grid-height grid)))
    (let loop ((ix 0) (x 0) (y 0) (result init))
      (cond ((= y height)
             result)
            ((= x width)
             (goto loop ix 0 (+ y 1) result))
            (else
             (let* ((value (grid-buffer-ref grid ix))
                    (result (proc ix x y value result)))
               (goto loop (+ ix 1) (+ x 1) y result)))))))

(define (grid-for-each proc grid)
  (grid-fold (lambda (ix x y value result)
               (proc ix x y value)
               result)
             grid (unspecific)))

(define (grid-update! proc grid)
  (grid-for-each (lambda (ix x y value)
                   (let ((value (proc ix x y value)))
                     (grid-buffer-set! grid ix value)))
                 grid)
  (grid-buffer-swap! grid))

(define (grid-unfold proc width height)
  (let ((grid (create-grid width height)))
    (grid-update! (lambda (ix x y value)
                    (proc ix x y))
                  grid)
    grid))