Directional pointing

2 files changed, 67 insertions, 1 deletions

diff --git a/virtual-programs/points-at.folk b/virtual-programs/points-at.folk
new file mode 100644
index 00000000..b68684de
--- /dev/null
+++ b/virtual-programs/points-at.folk
@@ -0,0 +1,49 @@
+
+set pi 3.1415926535897931
+
+When when /rect/ points /direction/ at /someone/ /lambda/ with environment /e/ {
+  Wish $rect points $direction
+}
+
+When /someone/ wishes /rect/ points /direction/ & /rect/ has region /region/ {
+    lassign $region vertices edges
+    lassign $vertices a b c d
+
+    set cx [expr {([lindex $a 0] + [lindex $c 0])/2}]
+    set cy [expr {([lindex $a 1] + [lindex $c 1])/2}]
+
+    set width [vec2 distance $a $b]
+    set height [vec2 distance $a $d]
+
+    set radians [lindex $region 2]
+    if {$radians eq ""} {set radians 0}
+    #if {$radians < 0} { set radians [expr {$radians + ($pi*2)}]}
+
+    set whisker_radians $radians
+    set fac -1.0
+    set whisker_size [expr {$width * $fac}]
+
+    if {$direction eq "up"} {
+        set whisker_radians [expr {$radians + $pi / 2}]
+        set whisker_size [expr {$height * $fac}]
+    } 
+    if {$direction eq "left"} {
+        set whisker_radians [expr {$radians + $pi}]
+    } 
+    if {$direction eq "down"} {
+        set whisker_radians [expr {$radians + $pi * 1.5}]
+        set whisker_size [expr {$height * $fac}]
+    } 
+
+    set wx [expr {$cx + $whisker_size * [::tcl::mathfunc::cos [expr {-1 * $whisker_radians}]] }]
+    set wy [expr {$cy + $whisker_size * [::tcl::mathfunc::sin [expr {-1 * $whisker_radians}]] }]
+
+    Display::stroke [list [list $cx $cy] [list $wx $wy] ] 2 green
+
+    When /target/ has region /r2/ {
+        if {$target != $rect && \
+                [region contains $r2 [list $wx $wy]]} {
+            Claim $rect points $direction at $target
+        }
+    }
+}
diff --git a/virtual-programs/regions.folk b/virtual-programs/regions.folk
index 0f20d260..583e4681 100644
--- a/virtual-programs/regions.folk
+++ b/virtual-programs/regions.folk
@@ -54,7 +54,24 @@ namespace eval ::region {
         }
         set minDist
     }
-    namespace export distance
+
+    proc contains {r1 p} {
+        lassign $r1 vertices edges
+        lassign $vertices a b c d
+
+        # 0 <= dot(ab,ap) <= dot(ab,ab) && 0 <= dot(bc,bp) <= dot(bc,bc)
+	set ab [vec2 sub $b $a]
+        set ap [vec2 sub $p $a]
+        set bc [vec2 sub $c $b]
+        set bp [vec2 sub $p $b]
+        set dot_abap [vec2 dot $ab $ap]
+        set dot_bcbp [vec2 dot $bc $bp]
+
+        return [expr {0 <= $dot_abap && $dot_abap <= [vec2 dot $ab $ab] && \
+                0 <= $dot_bcbp && $dot_bcbp <= [vec2 dot $bc $bc]}]
+    }
+
+    namespace export distance contains
     namespace ensemble create
 }