Skip to content

Instantly share code, notes, and snippets.

@rmloveland
Created June 21, 2020 01:02
Show Gist options
  • Save rmloveland/553af702df491192510c38ebfab0ca53 to your computer and use it in GitHub Desktop.
Save rmloveland/553af702df491192510c38ebfab0ca53 to your computer and use it in GitHub Desktop.
(module-extends javafx.application.Application)
(import (srfi 1)
(class javafx.application Application)
(class javafx.scene Group Scene)
(class javafx.stage Stage)
(class javafx.scene.canvas Canvas)
(class javafx.scene.canvas GraphicsContext)
(class javafx.scene.paint Color))
;; Geometry code
;; Point data type. A Shape (defined below) is a list of Points.
;; Every fundamental operation is defined on the Point; to apply each
;; operation to a Shape, we map it across each Point.
(define (point? x)
(and (pair? x)
(number? (first x))
(number? (second x))
(= 2 (length x))))
(define (point=? p1 p2)
(and (point? p1)
(point? p2)
(equal? p1 p2)))
(define (shrink-point point ratio)
(if (point? point)
(let* ((x (first point))
(y (second point))
(x* (if (= x 0) x (* x ratio)))
(y* (if (= y 0) y (* y ratio))))
(list x* y*))
point))
(define (translate-point point direction box-width)
;; A point is an (X Y) pair. To translate it (a.k.a. move it in a
;; direction), we convert each point by a different value, depending
;; on the direction of movement, and the size of the overall box we
;; are in. This assumes it is operating on a POINT that is already
;; "shrunken" during the first step of the curve-drawing process.
;;
;; DIRECTION is a compass direction: NORTH EAST NORTHEAST
(let ((x (first point))
(y (second point)))
(case direction
((east) (list x (+ y (/ box-width 2))))
((south) (list (+ x (/ box-width 2)) y))
((southeast) (list (+ x (/ box-width 2)) (+ y (/ box-width 2))))
(else 'UNSUPPORTED-DIRECTION))))
(define (rotate-point point pivot rad)
(if (point=? point pivot)
point
(let* ((x (first point))
(y (second point))
(pivot-x (first pivot))
(pivot-y (second pivot))
;; https://stackoverflow.com/questions/6645093/how-to-rotate-a-group-of-2d-shapes-around-an-arbitrary-point
(x* (+ pivot-x (- (* (- x pivot-x) (cos rad)) (* (- y pivot-y) (sin rad)))))
(y* (+ pivot-y (+ (* (- x pivot-x) (sin rad)) (* (- y pivot-y) (cos rad))))))
(list x* y*))))
;; Operations on Shapes. A Shape is a list of Points.
(define (bbox? x)
(and (list? x)
(= (length x) 2)
(point? (first x))
(point? (second x))))
(define (shape? x)
(and (list? x)
(point? (first x))
(not (bbox? x))))
(define (shrink-shape shape ratio)
(map (lambda (point) (shrink-point point ratio)) shape))
(define (translate-shape shape direction box-width)
(map (lambda (point) (translate-point point direction box-width)) shape))
(define (shape-bbox shape)
;; A 'bbox' (bounding box) is a 2-element list of Points that
;; delineates the lower left and upper right corners of the bounding
;; box that surrounds a SHAPE. Bounding boxes are needed for the
;; rotation operation.
(let* ((xs (map first shape))
(ys (map second shape))
(lower-left (list (apply min xs) (apply min ys)))
(upper-right (list (apply max xs) (apply max ys))))
(list lower-left upper-right)))
(define (bbox-center bbox)
(let ((min-x (first (first bbox)))
(min-y (second (first bbox)))
(max-x (first (second bbox)))
(max-y (second (second bbox))))
(list (+ min-x (/ (- max-x min-x) 2))
(+ min-y (/ (- max-y min-y) 2)))))
(define (rotate-shape shape rad)
(let* ((bbox (shape-bbox shape))
(pivot (bbox-center bbox)))
(map (lambda (point)
(let ((x (first point))
(y (second point)))
(rotate-point point pivot rad))) shape)))
(define reflect-shape reverse)
(define merge-shapes append)
(define (shape-closed? shape)
(equal? (first shape) (last shape)))
(define (close-shape shape)
(if (shape-closed? shape)
shape
(let ((start (first shape)))
(append shape (list start)))))
;; Distances between points
(define (square x) (* x x))
(define (sum-of-squares x y)
(+ (square x) (square y)))
(define (distance-between p1 p2)
(let* ((x1 (first p1))
(y1 (second p1))
(x2 (first p2))
(y2 (second p2)))
(sqrt (sum-of-squares (- x2 x1)
(- y2 y1)))))
;; Hilbert Curve
(define (h0 box-width)
(let* ((x (/ box-width 2))
(y x))
(list (list x y))))
(define (hilbert order width)
(let loop ((count 0)
(shape (h0 width)))
(if (= count order)
shape
(let* ((next-shape (shrink-shape shape 0.5))
(upper-left (reflect-shape (rotate-shape next-shape (* 3.14159 1.5))))
(upper-right (translate-shape next-shape 'east width))
(lower-left (translate-shape next-shape 'south width))
(lower-left* (reflect-shape (rotate-shape lower-left (* 3.14159 .5))))
(lower-right (translate-shape next-shape 'southeast width)))
(loop (+ count 1)
(merge-shapes upper-left upper-right lower-right lower-left*))))))
;; Kawa main loop
(define (start (stage ::Stage))
(let* ((root (Group))
(scene (Scene root 1024 1024 Color:WHITE))
(canvas (Canvas 1024 1024))
(gc (canvas:getGraphicsContext2D))
(children (root:getChildren))
(curve (hilbert 7 1024))
(curve-length (length curve))
(x-points (double[] length: curve-length))
(y-points (double[] length: curve-length)))
;; Populate Java arrays from Scheme lists
(define (fill-arrays! x-array y-array the-list)
(let ((list-len (length the-list))
(x-len (length x-array))
(y-len (length y-array)))
(if (= list-len x-len y-len)
(let loop ((count 0))
(if (= count list-len)
'DONE
(let* ((this-pair (list-ref the-list count))
(x (first this-pair))
(y (second this-pair)))
(begin
(set! (x-array count) x)
(set! (y-array count) y)
(loop (+ count 1))))))
'FAIL)))
(fill-arrays! x-points y-points curve)
(gc:setStroke Color:BLUE)
(gc:setLineWidth 1)
(gc:strokePolyline x-points y-points curve-length)
(children:add canvas)
(stage:setTitle "Hilbert Square")
(stage:setScene scene)
;; (stage:setResizable #f)
(stage:show)))
(Application:launch (module-class))
;; eof
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment