[commit] r2771 - dev

[repository service]

Author: wmb
Date: Tue Dec 13 22:36:57 2011
New Revision: 2771
URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2771

Log:
New "touchgrid.fth" package - not used yet.

Added:
   dev/touchgrid.fth

Added: dev/touchgrid.fth
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ dev/touchgrid.fth	Tue Dec 13 22:36:57 2011	(r2771)
@@ -0,0 +1,110 @@
+dev /packages
+new-device
+
+" touchgrid" device-name
+
+0 instance value offset-x
+0 instance value offset-y
+0 instance value pitch-x
+0 instance value pitch-y
+0 instance value x-cols
+0 instance value y-rows
+0 instance value full?
+
+: full-grid  ( x-cols y-rows -- )
+   to y-rows  to x-cols                  ( )
+
+   screen-wh                             ( w h )
+
+   dup y-rows /  to pitch-y              ( w h )
+   y-rows pitch-y * - 2/ to offset-y     ( w )
+   
+   dup x-cols /  to pitch-x              ( w )
+   x-cols pitch-x * - 2/ to offset-x     ( )
+
+   true to full?                         ( )
+;
+: exact-grid  ( offset-x offset-y  pitch-x pitch-y  x-cols y-rows  -- )
+   to y-rows  to x-cols  to pitch-y  to pitch-x  to offset-y  to offset-x
+   false to full?
+;
+
+: dimensions  ( -- w h )  " dimensions" $call-parent  ;
+: pad?  ( -- false | x y z down? contact# true )  " pad?" $call-parent  ;
+
+: hit?  ( -- false | x-col y-row down? contact# true )
+   pad?  0=  if  false exit  then    ( x y z down? contact# )
+   rot drop  2>r                     ( x y r: down? contact# )
+   swap offset-x - pitch-x /         ( y x-col  r: down? contact# )
+   swap offset-y - pitch-y /         ( x-col y-row  r: down? contact# )
+   full?  if                         ( x-col y-row  r: down? contact# )
+      swap  0 max  x-cols min        ( y-row x-col'  r: down? contact# )
+      swap  0 max  y-rows min        ( x-col y-row'  r: down? contact# )
+   else                              ( x-col y-row  r: down? contact# )
+      over 0 x-cols within 0=  if    ( x-col y-row  r: down? contact# )
+	 2r> 4drop false exit        ( -- false )
+      then                           ( x-col y-row  r: down? contact# )
+      dup 0 y-rows within 0=  if     ( x-col y-row  r: down? contact# )
+	 2r> 4drop false exit        ( -- false )
+      then                           ( x-col y-row  r: down? contact# )
+   then                              ( x-col y-row  r: down? contact# )
+   2r>  true
+;
+
+0 instance value down?
+: one-hit?  ( -- false | x-col y-row true )
+   hit?  if                   ( x-col y-row down? contact# )
+      if                      ( x-col y-row down? )
+	 \ Primary contact
+	 if                   ( x-col y-row )
+	    \ Touch event
+	    down?  if         ( x-col y-row )
+	       \ Suppress repetition
+	       2drop false    ( false )
+	    else              ( x-col y-row )
+               \ Initial touch - return coordinates
+	       true to down?  ( x-col y-row )
+               true           ( x-col y-row true )
+	    then              ( false | x-col y-row true )
+	 else                 ( x-col y-row )
+            \ Release event
+	    false to down?    ( x-col y-row )
+	    2drop false       ( false )
+	 then                 ( false | x-col y-row true )
+      else                    ( x-col y-row down? )
+	 \ Ignore non-primary contacts
+	 3drop false          ( false )
+      then                    ( false | x-col y-row true )
+   else                       ( )
+      false                   ( false )
+   then                       ( false | x-col y-row true )
+;
+: #contacts  ( -- n )  " #contacts" $call-parent  ;
+: open  ( -- okay? )  true  ;
+: close  ( -- )  ;
+
+0 [if]
+0 value #contacts
+0 value contacts
+
+: one-hit?  ( -- false | x-col y-row true )
+   hit?  if              ( x-col y-row down? contact# )
+      contacts na+       ( x-col y-row down? 'contact )
+      swap  if           ( x-col y-row 'contact )
+         dup @  if       ( x-col y-row 'contact )
+	    3drop false  ( false )  \ Ignore continued down
+         else            ( x-col y-row 'contact )
+            on           ( x-col y-row )
+	    true         ( x-col y-row true )
+         then            ( false | x-col y-row true )
+      else               ( x-col y-row 'contact )
+         off             ( x-col y-row )
+	 2drop false     ( false )
+   else                  ( )
+      false              ( false )
+   then                  ( false | x-col y-row true )
+;
+[then]
+
+finish-device
+device-end