Skip to content

Instantly share code, notes, and snippets.

What would you like to do?
(module grid *
(import chicken scheme ports)
(include "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))
;; 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
(lambda (d r x y) (grid-set! new-grid x y d)))
;; 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)))
(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))))
;; 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))))))))
(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)
(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 ">"))
;; -*- scheme -*-
(compile -s -J grid-module.scm -o
(compile -s grid.import.scm)
(install-extension 'grid '("" ""))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.