(define (horiz-pixels-per-quarter-inch gv)
	(let* ((gt (slot-ref gv 'graph-toplevel))
	       (f  (make <frame> :parent gt :width '1i :height '1i))
	       (w  (/ (width f) 4)))
	    (destroy f)
	    w))

(define (vert-pixels-per-quarter-inch gv)
	(let* ((gt (slot-ref gv 'graph-toplevel))
	       (f  (make <frame> :parent gt :width '1i :height '1i))
	       (w  (/ (height f) 4)))
	    (destroy f)
	    w))

(define (h-quarter-inches gv)
	(/ (slot-ref gv 'xpixels) (horiz-pixels-per-quarter-inch gv)))

(define (v-quarter-inches gv)
	(/ (slot-ref gv 'ypixels) (vert-pixels-per-quarter-inch gv)))

(define (ruler-line-offset x)
	(cond ((equal? (inexact->exact x) 0)  10)
	      ((equal? (inexact->exact x) 2)  7)
	      (#t      3)))

(define (horiz-quarter-line-coords gv quarter)
	(let*((ppi    (horiz-pixels-per-quarter-inch gv))
	      (startx (* quarter ppi))
	      (endx   (+ startx ppi))
	      (q-mod   (modulo quarter 4))
	      (qe-mod   (modulo (+ quarter 1) 4)))
	(list startx 0 startx (ruler-line-offset q-mod) startx 0
              endx 0 endx (ruler-line-offset qe-mod) endx 0)))

(define (vert-quarter-line-coords gv quarter)
	(let*((ppi    (vert-pixels-per-quarter-inch gv))
	      (starty (* quarter ppi))
	      (endy   (+ starty ppi))
	      (q-mod   (modulo quarter 4))
	      (qe-mod   (modulo (+ quarter 1) 4)))
	(list 0 starty  (ruler-line-offset q-mod) starty 0 starty
              0 endy (ruler-line-offset qe-mod) endy 0 endy)))

(define (horiz-ruler-coords-aux gv q-inches)
	(cond ((<= q-inches 0) '())
	      (#t (append (horiz-quarter-line-coords gv q-inches)
			  (horiz-ruler-coords-aux gv (- q-inches 1))))))

(define (horiz-ruler-coords gv gc)
	(let*((q-inches (floor (/ (slot-ref gv 'xpixels)
				  (horiz-pixels-per-quarter-inch gv)))))
		(horiz-ruler-coords-aux gv q-inches)))

(define (horiz-ruler gv)
	(let*((gc (slot-ref gv 'graph-canvas))
	      (crds (horiz-ruler-coords gv gc)))
	  (make <line> :parent gc :coords crds)))

(define (vert-ruler-coords-aux gv q-inches)
	(cond ((<= q-inches 0) '())
	      (#t (append (vert-quarter-line-coords gv q-inches)
			  (vert-ruler-coords-aux gv (- q-inches 1))))))

(define (vert-ruler-coords gv gc)
	(let*((q-inches (floor (/ (slot-ref gv 'xpixels)
				  (vert-pixels-per-quarter-inch gv)))))
		(vert-ruler-coords-aux gv q-inches)))

(define (vert-ruler gv)
	(let*((gc (slot-ref gv 'graph-canvas))
	      (crds (vert-ruler-coords gv gc)))
	  (make <line> :parent gc :coords crds)))

(define (horiz-ruler-pointer gv x)
	(if gv 
	  (make <line> :parent (slot-ref gv 'graph-canvas)
	               :coords (list (- x 5) 0 (+ x 5) 0 x 5 (- x 5) 0))))

(define (vert-ruler-pointer gv x)
	(if gv 
	  (make <line> :parent (slot-ref gv 'graph-canvas)
	               :coords (list (- x 5) 0 (+ x 5) 0 x 5 (- x 5) 0))))

(define (move-h-pointer ptr x y)
	(slot-set! ptr 'coords (list (- x 5) 0 (+ x 5) 0 x 5 (- x 5) 0)))

(define (move-v-pointer ptr x y)
	(slot-set! ptr 'coords (list 0 (- y 5) 0 (+ y 5) 5 y 0 (- y 5))))

(define (gridding gv)
	(let* ((h (horiz-ruler gv))
	       (v (vert-ruler gv))
	       (hp (horiz-ruler-pointer gv 5))
	       (vp (vert-ruler-pointer gv 5)))
	   (slot-set! gv 'grid-objects (list h v hp vp))))

(define (nearest-grid-x hppqi x)
	(let*((ix (inexact->exact x))
	      (ihppqi (inexact->exact hppqi))
	      (lmod (modulo ix ihppqi))
	      (rmod (- ihppqi lmod)))
	  (if (> lmod rmod) (+ ix rmod) (- ix lmod))))

(define (nearest-grid-y vppqi y)
	(let*((iy (inexact->exact y))
	      (ivppqi (inexact->exact vppqi))
	      (lmod (modulo iy ivppqi))
	      (rmod (- ivppqi lmod)))
	  (if (> lmod rmod) (+ iy rmod) (- iy lmod))))

(define (remove-gridding gv)
	   (map destroy (slot-ref gv 'grid-objects))
	   (slot-set! gv 'grid-objects '()))

(define-generic snap-to-grid)
(define-method snap-to-grid ((vi <vertex-item>))
	(let* ((gv (slot-ref vi 'graph-view))
	       (hppqi (horiz-pixels-per-quarter-inch gv))
	       (vppqi (vert-pixels-per-quarter-inch gv))
	       (crds (coords vi)))
	   (move-vertex-mouse vi 
			(nearest-grid-x hppqi (car crds))
			(nearest-grid-y vppqi (cadr crds)))
	   (update-edges vi (car crds) (cadr crds) 
				     (slot-ref vi 'vertex)
				     (slot-ref gv 'vertex-table)
				     (slot-ref gv 'edge-table) 
				     (incident-edges (slot-ref vi 'vertex)))))

(provide "grid")
