From 4a9e4ea8a1e569564072481d7ebf74e2c1e35055 Mon Sep 17 00:00:00 2001
From: =?utf8?q?Micha=C5=82=20=22phoe=22=20Herda?= <phoe@disroot.org>
Date: Thu, 30 Dec 2021 10:59:57 +0100
Subject: [PATCH] Add radial gradients

---
 doc/index.html | 14 ++++++++++++++
 gradient.lisp  | 32 ++++++++++++++++++++++----------
 package.lisp   |  2 ++
 3 files changed, 38 insertions(+), 10 deletions(-)

diff --git a/doc/index.html b/doc/index.html
index 527e475..7d7da84 100644
--- a/doc/index.html
+++ b/doc/index.html
@@ -404,6 +404,20 @@ to the end color from the start point to the midpoint, then back to
 the start color from the midpoint to the end point
 </ul>
 
+
+<p>Two coordinate functions are available:
+
+<ul>
+
+<li> <tt>CARTESIAN-COORDINATES</tt>, the default, creates a linear
+gradient.
+
+<li> <tt>POLAR-COORDINATES</tt> creates a radial gradient with the
+start point denoting the start of the circle and the end point
+denoting the ending circle.
+</ul>
+
+
 <pre><img style='float: right' class='transparent'
  src='linear-gradient.png'>(defun gradient-example (file)
   (with-canvas (:width 200 :height 50)
diff --git a/gradient.lisp b/gradient.lisp
index a89fe73..c1c989b 100644
--- a/gradient.lisp
+++ b/gradient.lisp
@@ -28,14 +28,6 @@
 
 (in-package #:vecto)
 
-(defun gradient-parameter-fun (x0 y0 x1 y1)
-  (lambda (x y)
-    (let ((numerator (+ (* (- x1 x0) (- x x0))
-                        (* (- y1 y0) (- y y0))))
-          (denominator (+ (expt (- x1 x0) 2)
-                          (expt (- y1 y0) 2))))
-      (/ numerator denominator))))
-
 (defun linear-domain (param)
   (clamp-range 0 param 1))
 
@@ -45,6 +37,25 @@
         param
         (- 2 param))))
 
+(defun cartesian-coordinates (x0 y0 x1 y1)
+  (lambda (x y)
+    (let ((numerator (+ (* (- x1 x0) (- x x0))
+                        (* (- y1 y0) (- y y0))))
+          (denominator (+ (expt (- x1 x0) 2)
+                          (expt (- y1 y0) 2))))
+      (/ numerator denominator))))
+
+(defun polar-coordinates (x0 y0 x1 y1)
+  (flet ((distance (start-x start-y end-x end-y)
+           (let ((x-distance (- end-x start-x))
+                 (y-distance (- end-y start-y)))
+             (sqrt (+ (expt x-distance 2)
+                      (expt y-distance 2))))))
+    (let ((original-distance (distance x0 y0 x1 y1)))
+      (lambda (x y)
+        (let ((distance (distance x0 y0 x y)))
+          (- 1 (/ (- original-distance distance) original-distance)))))))
+
 (defun set-gradient-fill (x0 y0
                           r0 g0 b0 a0
                           x1 y1
@@ -52,10 +63,11 @@
                           &key
                           (extend-start t)
                           (extend-end t)
-                          (domain-function 'linear-domain))
+                          (domain-function 'linear-domain)
+                          (coordinates-function 'cartesian-coordinates))
   (let* ((matrix (transform-matrix *graphics-state*))
          (fun (make-transform-function (invert-matrix matrix)))
-         (gfun (gradient-parameter-fun x0 y0 x1 y1)))
+         (gfun (funcall coordinates-function x0 y0 x1 y1)))
     (setf r0 (float-octet r0)
           g0 (float-octet g0)
           b0 (float-octet b0)
diff --git a/package.lisp b/package.lisp
index fc0a4f1..cd2bf80 100644
--- a/package.lisp
+++ b/package.lisp
@@ -81,6 +81,8 @@
    #:set-gradient-fill
    #:linear-domain
    #:bilinear-domain
+   #:cartesian-coordinates
+   #:polar-coordinates
    ;; graphics state coordinate transforms
    #:translate
    #:rotate
-- 
2.11.4.GIT