grid-module.scm

(module grid *
  (import chicken scheme ports)
  (include "grid.scm"))

grid.scm

(use srfi-4)

(define-record grid type w h getter setter printer)


(define (grid-ref grid x y)    ((grid-getter grid) x y))
(define (grid-set! grid x y v) ((grid-setter grid) x y v))

(define (grid-fold grid initial procDRXY)
  (let ((w (grid-w grid)) (h (grid-h grid)))
    (let loopy ((y 0) (r initial))
      (if (>= y h) r
          (let loopx ((x 0) (r r))
            (if (>= x w)
                (loopy (fx+ y 1) r)
                (loopx (fx+ x 1) (procDRXY (grid-ref grid x y) r x y))))))))



(define (grid-for-each grid procDXY)
  (let ((w (grid-w grid)) (h (grid-h grid)))
    (let loopy ((y 0))
      (if (>= y h) (void)
          (let loopx ((x 0))
            (if (>= x w)
                (loopy (fx+ y 1))
                (begin (procDXY (grid-ref grid x y) x y)
                       (loopx (fx+ x 1)))))))))


(define (grid-map grid procD)
  (grid-fold grid
             (vector-grid (grid-w grid) (grid-h grid))
             (lambda (d new x y)
               (grid-set! new x y (procD d))
               new)))


;; generic (without bound checks)
(define (vector-grid w h #!optional (initial #f))
  (define v (make-vector (* w h) initial))
  (define (get x y)   (vector-ref  v (+ (* w y) x)))
  (define (set x y d) (vector-set! v (+ (* w y) x) d))
  (make-grid 'vector w h get set #f))

;; ;; simple u8vector grid implementation without bound-checks.
;; (define (u8-grid w h #!optional (initial 0))
;;   (define (get v x y)   (u8vector-ref  v (+ (* w y) x)))
;;   (define (set v x y d) (u8vector-set! v (+ (* w y) x) d))
;;   (make-grid 'u8 w h get set (make-u8vector (* w h) initial)))

;; (define (s32-grid w h #!optional (initial 0))
;;   (define (get v x y)   (s32vector-ref  v v (+ (* w y) x)))
;;   (define (set v x y d) (s32vector-set! v v (+ (* w y) x) d))
;;   (make-grid 's32 w h get set (make-s32vector (* w h) initial)))

;; new grid with same dimensions
(define (same-grid grid #!optional initial)
  (vector-grid (grid-w grid) (grid-h grid) initial))

;; todo, procedure for this needs to be grid-type-specific
(define (grid-clone grid)
  (let ((new-grid (same-grid grid)))
    (grid-fold grid
               #f
               (lambda (d r x y) (grid-set! new-grid x y d)))
    new-grid))

;; passthrough to `grid`, unless outside of the width and heigh
;; parameter in which case `outside` is called.
(define (bounded-grid grid #!optional (outside (lambda (x y) #f)))
  (define (inside? x y)
    (and (<  x (grid-w grid))
         (<  y (grid-h grid))
         (>= x 0) (>= y 0)))
  
  (make-grid (cons 'bounded (grid-type grid))
             (grid-w grid) (grid-h grid)
             (lambda (x y)   (if (inside? x y)
                            (grid-ref grid x y)
                            (outside x y)))
             (lambda (x y v) (and (inside? x y)
                             (grid-set! grid x y v)))
             #f))

(define (strings->grid . ss)
  (define h (length ss))
  (define w (string-length (car ss)))
  (define g (vector-grid w h 0))

  (grid-fold g 0
             (lambda (d r  x y)
               (grid-set! g x y (string-ref (list-ref ss y) x))))
  g)

;; standard tabular printer layout
(define (make-grid-printer show)
  (lambda (grid)
   (define maxw
     (grid-fold grid 0
                (lambda (d r  x y)
                  (max r (string-length (with-output-to-string (lambda () (show d))))))))
   (newline)
   (grid-fold grid 0
              (lambda (d r x y)
                (if (not (= r y )) (newline))
                (define str (with-output-to-string (lambda () (show d))))
                (display (make-string (- maxw (string-length str)) #\space))
                (display str)
                y))
   (newline)))


(define-record-printer (grid i out)
  (fprintf out "#<grid ~S ~Sx~S" (grid-type i) (grid-w i) (grid-h i))
  (and (< (grid-w i) 1000)
       (< (grid-h i) 1000)
       ((or (grid-printer i) (make-grid-printer (lambda (x) (display " ") (display x)))) i))
  (fprintf out ">"))

grid.setup

;; -*- scheme -*-

(compile -s -J grid-module.scm -o grid.so)
(compile -s grid.import.scm)

(install-extension 'grid '("grid.so" "grid.import.so"))