From abc5c1a39367cf8fbabf5d99f27fa12fb971c802 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sat, 30 Apr 2016 13:00:24 -0700 Subject: [PATCH] planetarium/terrain.scm (make-terrain): Take all args with keywords. --- src/planetarium/mit-3d.pkg | 1 + src/planetarium/mit-check.sh | 6 ++- src/planetarium/terrain.scm | 90 ++++++++++++++++++++++++++---------- 3 files changed, 70 insertions(+), 27 deletions(-) diff --git a/src/planetarium/mit-3d.pkg b/src/planetarium/mit-3d.pkg index 5e51d9b1f..795563f7b 100644 --- a/src/planetarium/mit-3d.pkg +++ b/src/planetarium/mit-3d.pkg @@ -39,6 +39,7 @@ USA. burst-string read-line write-string ->namestring error:wrong-type-argument real? ->flonum symbol-name guarantee-list-of-type->length + guarantee-procedure-of-arity guarantee-real universal-time->local-time-string define-class define-method initialize-instance system-global-environment diff --git a/src/planetarium/mit-check.sh b/src/planetarium/mit-check.sh index 22afb68f7..1c7b4b061 100755 --- a/src/planetarium/mit-check.sh +++ b/src/planetarium/mit-check.sh @@ -50,8 +50,10 @@ ${MIT_SCHEME_EXE} --prepend-library . <<\EOF (if (not (file-exists? "sample-terrain.txt")) ((access write-sample-terrain env) "sample-terrain.txt" 20 20)) - (let ((view (make-terrain "sample-terrain.txt" - 20 20 0. 0. .001))) + (let ((view (make-terrain 'filename "sample-terrain.txt" + 'rows 20 'columns 20 + 'latitude 0. 'longitude 0. + 'step .001))) (view 'position -.01 0. 2000.) (view 'heading 25.) (view 'tilt -45.))))) diff --git a/src/planetarium/terrain.scm b/src/planetarium/terrain.scm index 5c6205b10..4d974d677 100644 --- a/src/planetarium/terrain.scm +++ b/src/planetarium/terrain.scm @@ -26,16 +26,15 @@ USA. (declare (integrate-external "geometry")) -(define (make-terrain filename rows columns lat lng step color-function) - (let ((widget (%make-terrain filename rows columns - lat lng step color-function))) +(define (make-terrain . options) + (let ((widget (%make-terrain options))) (named-lambda (terrain command . args) (define (check-flonum-args num description) (if (not (= num (guarantee-list-of-type->length args real? "a real number" 'TERRAIN))) (error (string-append - "The "(symbol-name command)" command requires" + "The "(symbol-name command)" command requires " (number->string num '(int))" arguments: "description".")))) (cond @@ -71,27 +70,68 @@ USA. (else (error:wrong-type-argument command "a command name" 'TERRAIN)))))) -(define (%make-terrain filename rows columns lat lng step color-function) - (let ((window (gtk-window-new 'toplevel)) - (grid (gtk-grid-new)) - (label (gtk-label-new "")) - (matrix (make-heightmap-matrix filename rows columns))) - (gtk-window-set-title window (string-append "Terrain: " - (->namestring filename))) - (gtk-container-set-border-width window 5) - (gtk-widget-set-hexpand label #t) - (let* ((min.max (matrix-min.max matrix rows columns)) - (widget (make-terrain-viewport - matrix rows columns (car min.max) (cdr min.max) - (make-latitude/longitude lat lng) step color-function - label 300 300))) - (gtk-widget-set-vexpand widget #t) - (gtk-widget-set-hexpand widget #t) - (gtk-grid-attach grid widget 0 0 1 1) - (gtk-grid-attach grid label 0 1 1 1) - (gtk-container-add window grid) - (gtk-widget-show-all window) - widget))) +(define (%make-terrain options) + + (define (get-keyword-value klist key default) + (let loop ((klist klist)) + (if (pair? klist) + (if (eq? (car klist) key) + (car (cdr klist)) + (loop (cdr (cdr klist)))) + default))) + + (define no-value "") + + (define (get-flonum-option name) + (let ((v (get-keyword-value options name no-value))) + (guarantee-real v name) + (->flonum v))) + + (define (get-integer-option name default) + (let ((v (get-keyword-value options name no-value))) + (if (eq? v no-value) + default + (begin + (guarantee-integer v name) + v)))) + + (let ((filename (get-keyword-value options 'filename #f)) + (rows (get-integer-option 'rows #f)) + (columns (get-integer-option 'columns #f)) + (latitude (get-flonum-option 'latitude)) + (longitude (get-flonum-option 'longitude)) + (step (get-flonum-option 'step)) + (color-function + (let ((v (get-keyword-value options 'color-function #f))) + (and v (begin + (guarantee-procedure-of-arity + v 3 'make-terrain:color-function) + v)))) + (width (get-integer-option 'width 300)) + (height (get-integer-option 'height 300))) + (let ((matrix (make-heightmap-matrix filename rows columns)) + (origin (make-latitude/longitude latitude longitude)) + (title (if filename + (string-append "Terrain: "(->namestring filename)) + "Terrain"))) + (let ((window (gtk-window-new 'toplevel)) + (grid (gtk-grid-new)) + (label (gtk-label-new ""))) + (gtk-window-set-title window title) + (gtk-container-set-border-width window 5) + (gtk-widget-set-hexpand label #t) + (let* ((min.max (matrix-min.max matrix rows columns)) + (widget (make-terrain-viewport + matrix rows columns (car min.max) (cdr min.max) + origin step color-function + label width height))) + (gtk-widget-set-vexpand widget #t) + (gtk-widget-set-hexpand widget #t) + (gtk-grid-attach grid widget 0 0 1 1) + (gtk-grid-attach grid label 0 1 1 1) + (gtk-container-add window grid) + (gtk-widget-show-all window) + widget))))) (define-class ( (constructor make-terrain-viewport -- 2.25.1