Add syntactic sugar to (lispkit draw). Adapt demo program.

Author: objecthub

Sources/LispKit/Primitives/DrawingLibrary.swift

@@ -101,6 +101,9 @@ public final class DrawingLibrary: NativeLibrary {
 
   /// Dependencies of the library.
   public override func dependencies() {
+    self.`import`(from: ["lispkit", "core"],    "define-syntax", "syntax-rules")
+    self.`import`(from: ["lispkit", "control"], "let")
+    self.`import`(from: ["lispkit", "dynamic"], "parameterize")
     self.`import`(from: ["lispkit", "system"],  "current-directory")
   }
 
@@ -180,11 +183,61 @@ public final class DrawingLibrary: NativeLibrary {
     self.define(Procedure("font", font))
     self.define(Procedure("font-name", fontName))
     self.define(Procedure("font-size", fontSize))
+    self.define(Procedure("point?", isPoint))
     self.define(Procedure("point", point))
+    self.define(Procedure("point-x", pointX))
+    self.define(Procedure("point-y", pointY))
+    self.define(Procedure("size?", isSize))
     self.define(Procedure("size", size))
+    self.define(Procedure("size-width", sizeWidth))
+    self.define(Procedure("size-height", sizeHeight))
+    self.define(Procedure("rect?", isRect))
     self.define(Procedure("rect", rect))
     self.define(Procedure("rect-point", rectPoint))
     self.define(Procedure("rect-size", rectSize))
+    self.define(Procedure("rect-x", rectX))
+    self.define(Procedure("rect-y", rectY))
+    self.define(Procedure("rect-width", rectWidth))
+    self.define(Procedure("rect-height", rectHeight))
+    
+    // Syntax definitions
+    self.define("drawing", via: """
+      (define-syntax drawing
+        (syntax-rules ()
+          ((_ body ...)
+            (let ((d (make-drawing)))
+              (parameterize ((current-drawing d)) body ...)
+              d))))
+    """)
+    self.define("with-drawing", via: """
+      (define-syntax with-drawing
+        (syntax-rules ()
+          ((_ d body ...)
+            (parameterize ((current-drawing d)) body ...))))
+    """)
+    self.define("transform", via: """
+      (define-syntax transform
+        (syntax-rules ()
+          ((_ tf body ...)
+            (let ((t tf))
+              (enable-transformation t)
+              body ...
+              (disable-transformation t)))))
+    """)
+    self.define("shape", via: """
+      (define-syntax shape
+        (syntax-rules ()
+          ((_ body ...)
+            (let ((s (make-shape)))
+              (parameterize ((current-shape s)) body ...)
+              s))))
+    """)
+    self.define("with-shape", via: """
+      (define-syntax with-shape
+        (syntax-rules ()
+          ((_ s body ...)
+            (parameterize ((current-shape s)) body ...))))
+    """)
   }
 
   public override func initializations() {
@@ -1045,18 +1098,67 @@ public final class DrawingLibrary: NativeLibrary {
 
   // Fonts/points/sizes/rects
 
+  private func isPoint(expr: Expr) throws -> Expr {
+    guard case .pair(.flonum(_), .flonum(_)) = expr else {
+      return .false
+    }
+    return .true
+  }
+  
   private func point(xc: Expr, yc: Expr) throws -> Expr {
     let x = try xc.asDouble(coerce: true)
     let y = try yc.asDouble(coerce: true)
     return .pair(.flonum(x), .flonum(y))
   }
 
+  private func pointX(expr: Expr) throws -> Expr {
+    guard case .pair(.flonum(let x), .flonum(_)) = expr else {
+      throw RuntimeError.eval(.invalidPoint, expr)
+    }
+    return .flonum(x)
+  }
+  
+  private func pointY(expr: Expr) throws -> Expr {
+    guard case .pair(.flonum(_), .flonum(let y)) = expr else {
+      throw RuntimeError.eval(.invalidPoint, expr)
+    }
+    return .flonum(y)
+  }
+  
+  private func isSize(expr: Expr) throws -> Expr {
+    guard case .pair(.flonum(_), .flonum(_)) = expr else {
+      return .false
+    }
+    return .true
+  }
+  
   private func size(wc: Expr, hc: Expr) throws -> Expr {
     let w = try wc.asDouble(coerce: true)
     let h = try hc.asDouble(coerce: true)
     return .pair(.flonum(w), .flonum(h))
   }
 
+  private func sizeWidth(expr: Expr) throws -> Expr {
+    guard case .pair(.flonum(let w), .flonum(_)) = expr else {
+      throw RuntimeError.eval(.invalidSize, expr)
+    }
+    return .flonum(w)
+  }
+  
+  private func sizeHeight(expr: Expr) throws -> Expr {
+    guard case .pair(.flonum(_), .flonum(let h)) = expr else {
+      throw RuntimeError.eval(.invalidSize, expr)
+    }
+    return .flonum(h)
+  }
+  
+  private func isRect(expr: Expr) throws -> Expr {
+    guard case .pair(.pair(.flonum(_), .flonum(_)), .pair(.flonum(_), .flonum(_))) = expr else {
+      return .false
+    }
+    return .true
+  }
+  
   private func rect(fst: Expr, snd: Expr, thrd: Expr?, fth: Expr?) throws -> Expr {
     if let width = thrd {
       let x = try fst.asDouble(coerce: true)
@@ -1089,6 +1191,20 @@ public final class DrawingLibrary: NativeLibrary {
     return point
   }
 
+  private func rectX(expr: Expr) throws -> Expr {
+    guard case .pair(.pair(.flonum(let x), .flonum(_)), .pair(.flonum(_), .flonum(_))) = expr else {
+      throw RuntimeError.eval(.invalidRect, expr)
+    }
+    return .flonum(x)
+  }
+  
+  private func rectY(expr: Expr) throws -> Expr {
+    guard case .pair(.pair(.flonum(_), .flonum(let y)), .pair(.flonum(_), .flonum(_))) = expr else {
+      throw RuntimeError.eval(.invalidRect, expr)
+    }
+    return .flonum(y)
+  }
+  
   private func rectSize(expr: Expr) throws -> Expr {
     guard case .pair(.pair(.flonum(_), .flonum(_)), let size) = expr else {
       throw RuntimeError.eval(.invalidRect, expr)
@@ -1099,6 +1215,20 @@ public final class DrawingLibrary: NativeLibrary {
     return size
   }
 
+  private func rectWidth(expr: Expr) throws -> Expr {
+    guard case .pair(.pair(.flonum(_), .flonum(_)), .pair(.flonum(let w), .flonum(_))) = expr else {
+      throw RuntimeError.eval(.invalidRect, expr)
+    }
+    return .flonum(w)
+  }
+  
+  private func rectHeight(expr: Expr) throws -> Expr {
+    guard case .pair(.pair(.flonum(_), .flonum(_)), .pair(.flonum(_), .flonum(let h))) = expr else {
+      throw RuntimeError.eval(.invalidRect, expr)
+    }
+    return .flonum(h)
+  }
+  
   private func isFont(expr: Expr) -> Expr {
     if case .object(let obj) = expr, obj is ImmutableBox<NSFont> {
       return .true

Sources/LispKit/Resources/Examples/AvlTrees.scm

@@ -28,6 +28,7 @@
 ;;; either express or implied. See the License for the specific language governing permissions
 ;;; and limitations under the License.
 
+
 (define-library (avl-tree)
 
   (export make-avl-tree

Sources/LispKit/Resources/Examples/Coroutines.scm

@@ -16,6 +16,7 @@
 ;;;
 ;;; Author: Matt Might ([email protected])
 
+
 (import (srfi 31))
 
 ; *thread-queue* : list[continuation]

Sources/LispKit/Resources/Examples/HTTP.scm

@@ -28,6 +28,7 @@
 ;;; either express or implied. See the License for the specific language governing permissions
 ;;; and limitations under the License.
 
+
 (define (http-get-header url)
   (let-values (((header _) (http-get url)))
     header))

Sources/LispKit/Resources/Examples/Plot.scm

@@ -1,9 +1,9 @@
 ;;; Plot graphs into a PDF file
 ;;;
-;;; This is a demo of library (lispkit draw). Function `plot` draws a function over
-;;; a given range using a number of interpolation points into a given rectangle.
-;;; It is used a number of times in function `plot-demo-page` which explains how to
-;;; compose drawings and save them in a PDF file.
+;;; This is a demo of library (lispkit draw). Function `plot` draws a graph for a
+;;; function for a given range using a number of interpolation points into a given
+;;; rectangle. `plot` is used a number of times in function `plot-demo-page` which
+;;; explains how to compose drawings and save them in a PDF file.
 ;;;
 ;;; Usage: (plot-demo-page "graph-demo.pdf")
 ;;;
@@ -24,58 +24,59 @@
 (import (lispkit draw))
 
 ;; Plots a function `f` over range `[xmin; xmax]` using `n` interpolation points
-;; within rectangle `rect`. Prints `label` at the bottom of the graph.
+;; within rectangle `rect`. Prints `label` at the bottom of the graph. Returns the result
+;; as a drawing object.
 (define (plot f xmin xmax n rect label)
   (let* ((dx (/ (- xmax xmin) n))
          (xs (tabulate (fx1+ n) (lambda (i) (+ xmin (* i dx)))))
          (ys (map f xs))
          (ymin (apply min ys))
          (ymax (apply max ys))
-         (xfac (/ (car (rect-size rect)) (- xmax xmin)))
-         (yfac (/ (cdr (rect-size rect)) (- ymax ymin)))
+         (xfac (/ (rect-width rect) (- xmax xmin)))
+         (yfac (/ (rect-height rect) (- ymax ymin)))
          (ps (map (lambda (x y) (point (* xfac (- x xmin)) (* yfac (- y ymin)))) xs ys))
-         (shift (translate (car (rect-point rect)) (cdr (rect-point rect))))
-         (d (make-drawing)))
-    ; Interpolate the points and flip the shape
-    (define s (flip-shape (interpolate ps)))
-    ; Draw a bounding box
-    (define box (shape-bounds s))
-    (draw (rectangular (rect-point rect) (rect-size rect)) 0.5 d)
-    ; Draw the graph and coordinate axis
-    (enable-transformation shift d)
-    (if (and (<= xmin 0.0) (>= xmax 0.0))
-        (draw (polygon (point (* xfac (- xmin)) 0)
-                       (point (* xfac (- xmin)) (cdr (rect-size rect)))) 0.3 d))
-    (if (and (<= ymin 0.0) (>= ymax 0.0))
-        (draw (polygon (point 0 (+ (cdr (rect-size rect)) (* yfac ymin)))
-                       (point (car (rect-size rect)) (+ (cdr (rect-size rect)) (* yfac ymin))))
-              0.3 d))
-    (set-color (make-color 0.0 0.0 1.0 1.0) d)
-    (draw s 1.0 d)
-    ; Draw interpolation points
-    (set-color (make-color 0.0 0.0 0.0) d)
-    (set-fill-color (make-color 0.0 0.0 0.0) d)
-    (for-each (lambda (p) (fill (flip-shape (arc p 1 0) box) d)) ps)
-    ; Draw the label
-    (draw-text label
-               (point 30 (- (cdr (rect-size rect)) 12))
-               (font "Times-Italic" 7)
-               (make-color 0.3 0.3 0.3) d)
-    (disable-transformation shift d)
-    d))
+         (graph (flip-shape (interpolate ps))))
+    (drawing
+      ; Draw a bounding box
+      (draw (rectangular (rect-point rect) (rect-size rect)) 0.5)
+      ; Move rest of drawing into the bounding box
+      (transform (translate (rect-x rect) (rect-y rect))
+        ; Draw the coordinate axis
+        (make-color 0.3 0.3 0.3)
+        (if (and (<= xmin 0.0) (>= xmax 0.0))
+          (draw (line (point (* xfac (- xmin)) 0)
+                      (point (* xfac (- xmin)) (rect-height rect))) 0.3))
+        (if (and (<= ymin 0.0) (>= ymax 0.0))
+          (draw (line (point 0 (+ (rect-height rect) (* yfac ymin)))
+                      (point (rect-width rect) (+ (rect-height rect) (* yfac ymin)))) 0.3))
+        ; Draw flipped interpolation shape
+        (set-color (make-color 0 0 1))
+        (draw graph)
+        ; Draw interpolation points
+        (set-color (make-color 0 0 0))
+        (set-fill-color (make-color 0 0 0))
+        (for-each (lambda (p) (fill (flip-shape (circle p 1) (shape-bounds graph)))) ps)
+        ; Draw the label
+        (draw-text label
+                   (point 30 (- (rect-height rect) 12))
+                   (font "Times-Italic" 7)
+                   (make-color 0.3 0.3 0.3))))))
 
 ;; Creates a demo page consisting of a header and four graphs
 (define (plot-demo-page path)
   ; Create a new drawing
-  (define page (make-drawing))
-  ; Draw a header in font "Helvetica" of size 8
-  (draw-text "Demo of library (lispkit draw)"
-    (point 160 8) (font "Helvetica" 8) (make-color 0.0 0.0 0.0) page)
-  ; Plot four graphs
-  (draw-drawing (plot sin -1 6.3 50 (rect 10 30 200 100) "sin(x)") page)
-  (draw-drawing (plot cos -1 6.3 50 (rect 220 30 200 100) "cos(x)") page)
-  (draw-drawing (plot (lambda (x) (* (sin (* x 2)) (cos (/ x 4))))
-    -1 6.3 50 (rect 10 140 200 100) "sin(x*2)*cos(x/4)") page)
-  (draw-drawing (plot (lambda (x) (/ (* x x) 40)) -1 6.3 50 (rect 220 140 200 100) "x*x/40") page)
+  (define page
+    (drawing
+      ; Draw a header in font "Helvetica-Bold" of size 8
+      (draw-text "Demo of library (lispkit draw)"
+                 (point 160 8)
+                 (font "Helvetica-Bold" 8)
+                 (make-color 0 0 0))
+      ; Plot four graphs
+      (draw-drawing (plot sin -1 6.3 50 (rect 10 30 200 100) "sin(x)"))
+      (draw-drawing (plot cos -1 6.3 50 (rect 220 30 200 100) "cos(x)"))
+      (draw-drawing (plot (lambda (x) (* (sin (* x 2)) (cos (/ x 4))))
+        -1 6.3 50 (rect 10 140 200 100) "sin(x*2)*cos(x/4)"))
+      (draw-drawing (plot (lambda (x) (/ (* x x) 40)) -1 6.3 50 (rect 220 140 200 100) "x*x/40"))))
   ; Save drawing in a PDF file
   (save-drawing page path (size 430 250)))