extended vector-structs with build- functions

Author: vraid

package/vraid/struct.rkt

@@ -1,8 +1,6 @@
 #lang racket
 
-(require "struct/keyword-struct.rkt"
-         "struct/vector-struct.rkt")
+(require "require.rkt")
 
-(provide (all-from-out
-          "struct/keyword-struct.rkt"
-          "struct/vector-struct.rkt"))
+(require/provide "struct/keyword-struct.rkt"
+                 "struct/vector-struct.rkt")

package/vraid/struct/vector-struct.rkt

@@ -8,15 +8,27 @@
          "keyword-struct.rkt"
          "../util/vector-util.rkt")
 
-(provide vector-struct)
+(provide vector-struct
+         vec
+         flvec)
+
+(define vec build-vector-accessor)
+(define flvec build-flvector-accessor)
 
 (define-syntax (vector-struct stx)
   (syntax-case stx ()
-    [(_ id ([field : type] ...) opt ...)
+    [(_ id ([field : build-vector-accessor type] ...) opt ...)
      (with-syntax ([(set ...) (map (lambda (field)
                                      (format-id field "~a-set!" field))
                                    (syntax->list #'(field ...)))]
                    [struct/accessors (format-id #'id "~a/accessors" #'id)]
+                   [build-struct (format-id #'id "build-~a" #'id)]
+                   [(kw+function-type ...) (append*
+                                            (map (lambda (fld type)
+                                                   (list (syntax->keyword fld)
+                                                         (list #'Integer #'-> type)))
+                                                 (syntax->list #'(field ...))
+                                                 (syntax->list #'(type ...))))]
                    [(kw+vector-type ...) (append*
                                           (map (lambda (fld type)
                                                  (list (syntax->keyword fld)
@@ -37,4 +49,10 @@
              (ann (lambda (kw+fld ...)
                     (id (vector-accessor-get field) ...
                         (vector-accessor-set field) ...))
-                  (kw+vector-type ... -> id)))))]))
+                  (kw+vector-type ... -> id)))
+           (define build-struct
+             (ann (lambda (n)
+                    (lambda (kw+fld ...)
+                      (let ([field (build-vector-accessor n field)] ...)
+                        (struct/accessors kw+fld ...))))
+                  (Integer -> (kw+function-type ... -> id))))))]))

package/vraid/util/vector-util.rkt

@@ -1,9 +1,9 @@
 #lang typed/racket
 
-(provide (all-defined-out))
-
 (require math/flonum)
 
+(provide (all-defined-out))
+
 (: vector-index (All (a) (a (Vectorof a) -> Integer)))
 (define (vector-index e v)
   (let ([m (vector-member e v)])
@@ -14,13 +14,13 @@
 (: build-vector-ref (All (a) (Integer (Integer -> a) -> (Integer -> a))))
 (define (build-vector-ref count f)
   (let ([v (build-vector count f)])
-    (lambda: ([n : Integer])
+    (λ ([n : Integer])
       (vector-ref v n))))
 
 (: build-flvector-ref (Integer (Integer -> Float) -> (Integer -> Float)))
 (define (build-flvector-ref count f)
   (let ([v (build-flvector count f)])
-    (lambda: ([n : Integer])
+    (λ ([n : Integer])
       (flvector-ref v n))))
 
 (: vector-take-at-most (All (a) ((Vectorof a) Integer -> (Vectorof a))))
@@ -31,17 +31,38 @@
   ([get : (Integer -> A)]
    [set : (Integer A -> Void)]))
 
+(: vector-get (All (A) ((Vectorof A) -> (Integer -> A))))
+(define ((vector-get v) n)
+  (vector-ref v n))
+
+(: vector-set (All (A) ((Vectorof A) -> (Integer A -> Void))))
+(define ((vector-set v) n value)
+  (vector-set! v n value))
+
+(: flvector-get (FlVector -> (Integer -> Float)))
+(define ((flvector-get v) n)
+  (flvector-ref v n))
+
+(: flvector-set (FlVector -> (Integer Float -> Void)))
+(define ((flvector-set v) n value)
+  (flvector-set! v n value))
+
 (: make-vector-accessor (All (A) ((Vectorof A) -> (vector-accessor A))))
 (define (make-vector-accessor v)
-  (vector-accessor (lambda ([n : Integer])
-                   (vector-ref v n))
-                 (lambda ([n : Integer]
-                          [a : A])
-                   (vector-set! v n a))))
+  (vector-accessor
+   (vector-get v)
+   (vector-set v)))
 
 (: make-flvector-accessor (FlVector -> (vector-accessor Float)))
 (define (make-flvector-accessor v)
-  (vector-accessor (curry flvector-ref v)
-                 (lambda ([n : Integer]
-                          [a : Float])
-                   (flvector-set! v n a))))
+  (vector-accessor
+   (flvector-get v)
+   (flvector-set v)))
+
+(: build-vector-accessor (All (A) (Integer (Integer -> A) -> (vector-accessor A))))
+(define (build-vector-accessor n get)
+  (make-vector-accessor (build-vector n get)))
+
+(: build-flvector-accessor (Integer (Integer -> Float) -> (vector-accessor Float)))
+(define (build-flvector-accessor n get)
+  (make-flvector-accessor (build-flvector n get)))

planet/climate/climate-structs.rkt

@@ -36,19 +36,19 @@
      (climate-parameters-axial-tilt (planet-climate-parameters planet))))
 
 (vector-struct tile-climate-data
-               ([snow : Float]
-                [sunlight : Float]
-                [temperature : Float]
-                [humidity : Float]
-                [precipitation : Float]
-                [leaf-area-index : Float]))
+               ([snow : flvec Float]
+                [sunlight : flvec Float]
+                [temperature : flvec Float]
+                [humidity : flvec Float]
+                [precipitation : flvec Float]
+                [leaf-area-index : flvec Float]))
 
 (vector-struct corner-climate-data
-               ([river-flow : Float]))
+               ([river-flow : flvec Float]))
 
 (vector-struct edge-climate-data
-               ([river-flow : Float]
-                [air-flow : Float]))
+               ([river-flow : flvec Float]
+                [air-flow : flvec Float]))
 
 (struct/kw planet-climate planet-terrain
            ([parameters : climate-parameters]

planet/terrain-generation/planet-create.rkt

@@ -3,7 +3,6 @@
 (require vraid/math
          vraid/util
          math/flonum
-         "terrain-data.rkt"
          "../grid-base.rkt"
          "../heightmap.rkt"
          "../geometry.rkt"
@@ -19,13 +18,13 @@
 (define ((planet/sea-level sea-level) p)
   (let* ([tile-count (tile-count p)]
          [corner-count [corner-count p]]
-         [tile-data (make-tile-terrain-data tile-count
-                                            (curry tile-elevation p)
-                                            (λ ([n : Integer])
-                                              sea-level))]
-         [corner-data (make-corner-terrain-data corner-count
-                                                (curry corner-elevation p)
-                                                (curry corner-river-direction p))])
+         [tile-data ((build-tile-terrain-data tile-count)
+                     #:elevation (curry tile-elevation p)
+                     #:water-level (λ ([n : Integer])
+                                     sea-level))]
+         [corner-data ((build-corner-terrain-data corner-count)
+                       #:elevation (curry corner-elevation p)
+                       #:river-direction (curry corner-river-direction p))])
     (planet-terrain/kw
      #:planet-geometry p
      #:sea-level sea-level
@@ -38,24 +37,24 @@
   (planet-terrain/kw
    #:planet-geometry p
    #:sea-level (planet-sea-level p)
-   #:tile (make-tile-terrain-data (tile-count p)
-                                  (curry tile-elevation p)
-                                  (curry tile-water-level p))
-   #:corner (make-corner-terrain-data (corner-count p)
-                                      (curry corner-elevation p)
-                                      (curry corner-river-direction p))
+   #:tile ((build-tile-terrain-data (tile-count p))
+           #:elevation (curry tile-elevation p)
+           #:water-level (curry tile-water-level p))
+   #:corner ((build-corner-terrain-data (corner-count p))
+             #:elevation (curry corner-elevation p)
+             #:river-direction (curry corner-river-direction p))
    #:rivers (planet-rivers p)))
 
 (: heightmap->planet (Float FlVector -> (grid/heightmap -> planet-terrain)))
 (define ((heightmap->planet radius axis) gh)
   (let* ([grid (grid/heightmap-grid gh)]
          [h (grid/heightmap-heightmap gh)]
-         [tile (make-tile-terrain-data (tile-count grid)
-                                       (curry flvector-ref (heightmap-tiles h))
-                                       (λ ([n : Integer]) 0.0))]
-         [corner (make-corner-terrain-data (corner-count grid)
-                                           (curry flvector-ref (heightmap-corners h))
-                                           (λ ([n : Integer]) #f))])
+         [tile ((build-tile-terrain-data (tile-count grid))
+                #:elevation (curry flvector-ref (heightmap-tiles h))
+                #:water-level (λ ([n : Integer]) 0.0))]
+         [corner ((build-corner-terrain-data (corner-count grid))
+                  #:elevation (curry flvector-ref (heightmap-corners h))
+                  #:river-direction (λ ([n : Integer]) #f))])
 
     (planet-terrain/kw
      #:planet-geometry (planet-geometry/kw

planet/terrain-generation/river-generation.rkt

@@ -3,43 +3,10 @@
 (require vraid/flow
          vraid/sorted-tree
          "../grid-base.rkt"
-         "../terrain.rkt"
-         "terrain-data.rkt")
+         "../terrain.rkt")
 
 (provide planet/rivers)
 
-(: bad-river-end? (planet-terrain Integer -> Boolean))
-(define (bad-river-end? planet n)
-  (and (corner-land? planet n)
-       (not (corner-river-direction planet n))))
-
-(: has-bad-ends? (planet-terrain -> Boolean))
-(define (has-bad-ends? planet)
-  (ormap (curry bad-river-end? planet)
-         (range (corner-count planet))))
-
-(: lowest-nearby (planet-terrain Integer -> Float))
-(define (lowest-nearby planet n)
-  (foldl min
-         +inf.0
-         (map (curry corner-elevation planet)
-              (grid-corner-corner-list planet n))))
-
-(: highest-nearby (planet-terrain Integer -> Float))
-(define (highest-nearby planet n)
-  (foldl max
-         -inf.0
-         (map (curry corner-elevation planet)
-              (grid-corner-corner-list planet n))))
-
-(: elevate-ends! (planet-terrain -> Void))
-(define (elevate-ends! planet)
-  (for ([n (corner-count planet)])
-    (when (bad-river-end? planet n)
-      ((corner-terrain-data-elevation-set! (planet-terrain-corner planet))
-       n
-       (* 1.01 (highest-nearby planet n))))))
-
 (define-type corner-node (Pair Integer Float))
 
 (: ref (All (A) ((Vectorof A) -> (Integer -> A))))
@@ -130,12 +97,12 @@
 
 (: planet/rivers (planet-terrain -> planet-terrain))
 (define (planet/rivers p)
-  (let* ([tiles (make-tile-terrain-data (tile-count p)
-                                        (curry tile-elevation p)
-                                        (curry tile-water-level p))]
-         [corners (make-corner-terrain-data (corner-count p)
-                                            (curry corner-elevation p)
-                                            (curry corner-river-direction p))]
+  (let* ([tiles ((build-tile-terrain-data (tile-count p))
+                 #:elevation (curry tile-elevation p)
+                 #:water-level (curry tile-water-level p))]
+         [corners ((build-corner-terrain-data (corner-count p))
+                   #:elevation (curry corner-elevation p)
+                   #:river-direction (curry corner-river-direction p))]
          [p (planet-terrain/kw
              #:planet-geometry p
              #:sea-level (planet-sea-level p)
@@ -145,18 +112,3 @@
     (set-directions/floodfill! p)
     (struct-copy planet-terrain p
                  [rivers (river-trees p)])))
-
-; direction is -1 if no neighbouring corner has lower elevation
-(: lowest-corner-direction (planet-terrain Integer -> Fixnum))
-(define (lowest-corner-direction planet n)
-  (let* ([elevation (λ ([n : Integer])
-                      (corner-elevation planet n))]
-         [index/elevation (λ ([i : Fixnum])
-                            (cons i (elevation
-                                     (corner-corner planet n i))))]
-         [indices/elevation (map index/elevation
-                                 '(0 1 2))])
-    (car (argmin (λ ([p : (Pair Fixnum Float)])
-                   (cdr p))
-                 (cons (cons -1 (elevation n))
-                       indices/elevation)))))

planet/terrain-generation/terrain-data.rkt

@@ -14,12 +14,12 @@
 (define-type river-list (Listof river))
 
 (vector-struct tile-terrain-data
-               ([elevation : Float]
-                [water-level : Float]))
+               ([elevation : flvec Float]
+                [water-level : flvec Float]))
 
 (vector-struct corner-terrain-data
-               ([elevation : Float]
-                [river-direction : (Option Integer)]))
+               ([elevation : flvec Float]
+                [river-direction : vec (Option Integer)]))
 
 (struct/kw planet-terrain planet-geometry
            ([sea-level : Float]