Created
June 21, 2020 01:02
-
-
Save rmloveland/553af702df491192510c38ebfab0ca53 to your computer and use it in GitHub Desktop.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(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