Add pin-over and pin-under.

1 files changed, 33 insertions, 0 deletions

diff --git a/pict.scm b/pict.scm
index fdf9bbd..63cd1d9 100644
--- a/pict.scm
+++ b/pict.scm
@@ -89,6 +89,9 @@
             rc-superimpose
             rb-superimpose
 
+            pin-over
+            pin-under
+
             ;; colors
             rgb
             colors))
@@ -800,6 +803,36 @@ bottom."
   "Stack the given PICTS and align them right and at the bottom."
   (append-align 'right 'bottom picts))
 
+(define (pin-over base dx dy pict)
+  "Create a pict with the same dimensions as BASE, but with PICT
+placed on top.  PICT is offset from the top left corner of BASE by DX
+and DY."
+  (make-pict
+   `(svg (@ (height ,(pict-height base))
+            (width  ,(pict-width base))
+            (class "pinned")
+            (x 0)
+            (y 0))
+         ,(pict-sxml base)
+         ,((compose (attribute-modifier 'y (const dy))
+                    (attribute-modifier 'x (const dx)))
+           (pict-sxml pict)))))
+
+(define (pin-under base dx dy pict)
+  "Create a pict with the same dimensions as BASE, but with PICT
+placed underneath.  PICT is offset from the top left corner of BASE by
+DX and DY."
+  (make-pict
+   `(svg (@ (height ,(pict-height base))
+            (width  ,(pict-width base))
+            (class "pinned")
+            (x 0)
+            (y 0))
+         ,((compose (attribute-modifier 'y (const dy))
+                    (attribute-modifier 'x (const dx)))
+           (pict-sxml pict))
+         ,(pict-sxml base))))
+
 
 ;;; Colors