Changeset 2893


Ignore:
Timestamp:
Mar 15, 2012 12:19:06 AM (15 months ago)
Author:
wmb
Message:

OLPC XO-1,75 - trac #11695 - Added touchscreen support for graphical menu, factoring out common code in the touchscreen drivers and cleaning up some dead menu code in the process. For the older XO-3 build, the touchscreen could already be used to drive the menu in lieu of the nonexistent touchpad/mouse; now machines with both a touchscreen and a touchpad/mouse can use either interchangeably.

Files:
1 added
9 edited

Legend:

Unmodified
Added
Removed

  • cpu/arm/olpc/build-fw.fth

    r2882 r2893  
    753753\+ olpc-cl3 fload ${BP}/cpu/arm/olpc/exc7200-touchscreen.fth    \ Touchscreen driver and diagnostic 
    754754\+ olpc-cl3 fload ${BP}/dev/softkeyboard.fth                    \ On-screen keyboard 
    755 \+ olpc-cl3 devalias mouse /touchscreen 
    756755\+ olpc-cl2 fload ${BP}/cpu/arm/olpc/rm3150-touchscreen.fth    \ Touchscreen driver and diagnostic 
    757756fload ${BP}/cpu/arm/olpc/roller.fth     \ Accelerometer test 

  • cpu/arm/olpc/exc7200-touchscreen.fth

    r2789 r2893  
    440 0  " 4,8"  " /twsi" begin-package 
    55my-space encode-int  my-address encode-int encode+  " reg" property 
    6 " touchscreen" name 
    76 
    8 0 value screen-w 
    9 0 value screen-h 
    10 0 instance value invert-x? 
    11 0 instance value invert-y? 
     7\ XXX these are really platform-related, not touchscreen-related 
     8: targets?  ( -- flag )  true  ;  \ Used to be "final-test?" 
     9: .tsmsg  ( -- )  0 d# 27 at-xy  ." Touchscreen test.  Hit both targets to exit" cr  ; 
    1210 
    13 : dimensions  ( -- w h )  screen-w  screen-h  ; 
     11fload ${BP}/cpu/arm/olpc/touchscreen-common.fth 
    1412 
    15 : #contacts  ( -- n )  2  ; 
     13h# 7fff to touchscreen-max-x 
     14h# 7fff to touchscreen-max-y 
    1615 
    17 h# 7fff constant touchscreen-max-x 
    18 h# 7fff constant touchscreen-max-y 
    19  
    20 : invert-x  ( x -- x' )  touchscreen-max-x swap -  ; 
    21 : invert-y  ( y -- y' )  touchscreen-max-y swap -  ; 
    22  
    23 : scale-x  ( x -- x' ) 
    24    invert-x?  if  invert-x  then 
    25    screen-w touchscreen-max-x */ 
    26 ; 
    27 : scale-y  ( y -- y' ) 
    28    invert-y?  if  invert-y  then 
    29    screen-h touchscreen-max-y */ 
    30 ; 
     162 to #contacts 
    3117 
    3218\ Try to receive a mouse report packet.  If one arrives within 
    … …  
    4430   then                                    ( flags  r: z y x ) 
    4531 
    46    r>  scale-x                             ( flags  x'  r: z y ) 
    47    r>  scale-y                             ( flags  x y'  r: z ) 
     32   r> r> scale-xy                          ( flags  x' y'  r: z ) 
    4833 
    4934   r> 3 roll                               ( x y z flags ) 
    … …  
    5237   true                                    ( x y z down? contact# true ) 
    5338; 
    54 true value absolute? 
    5539: stream-poll?  ( -- false | x y buttons true ) 
    5640   pad?  if               ( x y z down? contact# ) 
    … …  
    6549; 
    6650 
    67 h# f800 constant red 
    68 h# 07e0 constant green 
    69 h# 001f constant blue 
    70 h# ffe0 constant yellow 
    71 h# f81f constant magenta 
    72 h# 07ff constant cyan 
    73 h# ffff constant white 
    74 h# 0000 constant black 
    75  
    76 variable pixcolor 
    77  
    78 h# 4 value y-offset 
    79 \ 0 value /line 
    80 \ 2 value /pixel 
    81  
    82  
    83 variable ptr 
    84  
    85 \ The following code receives and decodes touchpad packets 
    86  
    87 : show-packets  ( adr len -- ) 
    88    push-hex 
    89    bounds  ?do 
    90       i 6  bounds  ?do  i c@  3 u.r  loop  cr 
    91    6 +loop 
    92    pop-base 
    93 ; 
    94 : last-10  ( -- ) 
    95    ptr @  load-base -  d# 60  >  if 
    96       ptr @  d# 60 -  d# 60 
    97    else 
    98       load-base  ptr @  over - 
    99    then 
    100    show-packets 
    101 ; 
    102  
    10351\ Display raw data from the device, stopping when a key is typed. 
    10452: show-pad  ( -- ) 
    … …  
    10856; 
    10957 
    110 : button  ( color x -- ) 
    111    screen-h d# 50 -  d# 200  d# 30  fill-rectangle-noff 
    112 ; 
    113 d# 300 d# 300 2constant target-wh 
    114 : left-target   ( -- x y w h )  0 0  target-wh  ; 
    115 : right-target  ( -- x y w h )  screen-w screen-h  target-wh  xy-  target-wh  ; 
    116 false value left-hit? 
    117 false value right-hit? 
    118 : inside?  ( mouse-x,y  x y w h -- flag ) 
    119    >r >r         ( mouse-x mouse-y  x y  r: h w ) 
    120    xy-           ( dx dy ) 
    121    swap r> u<    ( dy x-inside? ) 
    122    swap r> u<    ( x-inside? y-inside? ) 
    123    and           ( flag ) 
    124 ; 
    125  
    126 : draw-left-target  ( -- )  green  left-target   fill-rectangle-noff  ; 
    127 : draw-right-target ( -- )  red    right-target  fill-rectangle-noff  ; 
    128  
    129 : ?hit-target  ( -- ) 
    130    pixcolor @  cyan =   if  \ touch1              ( x y ) 
    131       2dup  left-target  inside?  if              ( x y ) 
    132          yellow left-target  fill-rectangle-noff  ( x y ) 
    133          true to left-hit?                        ( x y ) 
    134          exit 
    135       then                                        ( x y ) 
    136    then                                           ( x y ) 
    137    pixcolor @ yellow =  if  \ touch2              ( x y ) 
    138       2dup  right-target  inside?  if             ( x y ) 
    139          yellow right-target  fill-rectangle-noff ( x y ) 
    140          true to right-hit?                       ( x y ) 
    141          exit 
    142       then                                        ( x y ) 
    143    then                                           ( x y ) 
    144 ; 
    145  
    146 : targets?  ( -- flag )  true  ;  \ Used to be "final-test?" 
    147  
    148 : track-init  ( -- ) 
    149 \   screen-ih package( bytes/line )package  to /line 
    150    load-base ptr ! 
    151 ; 
    152  
    153 : dot  ( x y -- ) 
    154    swap screen-w 3 - min  swap y-offset + screen-h 3 - min  ( x' y' ) 
    155    pixcolor @  -rot   3 3                   ( color x y w h ) 
    156    fill-rectangle-noff                      ( ) 
    157 ; 
    158  
    159 : background  ( -- ) 
    160    black  0 0  screen-w screen-h  fill-rectangle-noff 
    161    targets?  if 
    162       false to left-hit? 
    163       false to right-hit? 
    164       draw-left-target 
    165       draw-right-target 
    166    else 
    167       0 d# 27 at-xy  ." Touchscreen test.  Hit both targets to exit" cr 
    168    then 
    169 ; 
    170  
    171 : setcolor  ( contact# -- ) 
    172    case 
    173       0  of  cyan    endof 
    174       1  of  yellow  endof 
    175       2  of  magenta endof 
    176       3  of  blue    endof 
    177       ( default )  white swap 
    178    endcase 
    179  
    180    pixcolor !          
    181 ; 
    182 0 value pressure 
    183  
    184 : *3/5  ( n -- n' )  3 5 */  ; 
    185 : dimmer  ( color -- color' ) 
    186    565>rgb rot *3/5 rot *3/5 rot *3/5 rgb>565 
    187 ; 
    188  
    18958: track  ( x y z down? contact# -- ) 
    19059   setcolor                       ( x y z down? ) 
    191    0=  if 
    192       pixcolor @  dup dimmer  " replace-color" $call-screen 
    193       3drop exit 
     60   0=  if                         ( x y z ) 
     61      3drop  undot  exit          ( -- ) 
    19462   then                           ( x y z ) 
    19563   to pressure                    ( x y ) 
    … …  
    20270 
    20371   dot 
    204 ; 
    205  
    206 : handle-key  ( -- exit? ) 
    207    key upc  case 
    208       [char] P  of 
    209          cursor-on 
    210          cr last-10 
    211          key drop 
    212          background 
    213          false 
    214       endof 
    215  
    216       ( key )  true swap 
    217    endcase 
    218 ; 
    219  
    220 false value selftest-failed?  \ Success/failure flag for final test mode 
    221 : exit-test?  ( -- flag ) 
    222    targets?  if                       ( ) 
    223       \ If the targets have been hit, we exit with successa 
    224       left-hit? right-hit? and  if    ( ) 
    225          false to selftest-failed?    ( ) 
    226          true                         ( flag ) 
    227          exit 
    228       then                            ( ) 
    229  
    230       \ Otherwise we give the tester a chance to bail out by typing a key, 
    231       \ thus indicating failure 
    232       key?  0=  if  false exit  then  ( ) 
    233       key drop                        ( ) 
    234       true to selftest-failed?        ( ) 
    235       true                            ( flag ) 
    236       exit 
    237    then                               ( ) 
    238  
    239    \ If not final test mode, we only exit via a key - no targets 
    240    key?  if  handle-key  else  false  then  ( exit ? ) 
    24172; 
    24273: touchscreen-present?  ( -- flag ) 
    … …  
    25485   \ Read once to prime the interrupt 
    25586   d# 10 " get" $call-parent  4drop 4drop 2drop 
    256    " dimensions" $call-screen  to screen-h  to screen-w 
    25787 
    258    \ The "TI" tag controls the inverson of X and Y axes. 
    259    \ If the tag is missing, axes are not inverted.  If present 
    260    \ and the value contains either of the letters x or y, the 
    261    \ corresponding axis is inverted.  This is primarily for 
    262    \ development, using prototype touchscreens. 
    263    " TI" find-tag  if     ( adr len ) 
    264       begin  dup  while   ( adr len ) 
    265          over c@  upc  [char] x =  if  true to invert-x?  then 
    266          over c@  upc  [char] y =  if  true to invert-y?  then 
    267          1 /string        ( adr' len' ) 
    268       repeat              ( adr len ) 
    269       2drop               ( ) 
    270    then                   ( ) 
     88   set-geometry 
    27189 
    27290   flush 
    … …  
    292110   then 
    293111 
    294    cursor-off  track-init 
     112   cursor-off 
    295113 
    296114   \ Consume already-queued keys to prevent premature exit 
    … …  
    313131   targets?  if  selftest-failed?  else  false  then 
    314132; 
    315  
    316133 
    317134end-package 

  • cpu/arm/olpc/rm3150-touchscreen.fth

    r2775 r2893  
    440 0  " 4,60"  " /twsi" begin-package 
    55my-space encode-int  my-address encode-int encode+  " reg" property 
    6 " touchscreen" name 
    76 
    8 0 value screen-w 
    9 0 value screen-h 
     7\ XXX these are really platform-related, not touchscreen-related 
     8: targets?  ( -- flag )  final-test?  ; 
     9: .tsmsg  ( -- )  0 d# 27 at-xy  ." Touchscreen test.  Type a key to exit" cr  ; 
     10 
     11fload ${BP}/cpu/arm/olpc/touchscreen-common.fth 
     12 
     13d# 896 to touchscreen-max-x 
     14d# 672 to touchscreen-max-y 
     15 
     16d# 10 to #contacts 
    1017 
    1118: ts-b!  ( b reg# -- )  " smbus-b!" $call-parent  ; 
    1219: ts-b@  ( reg# -- b )  " smbus-b@" $call-parent  ; 
    13  
    14 d# 896 constant touchscreen-max-x 
    15 d# 672 constant touchscreen-max-y 
    1620 
    1721: 4b>xy  ( x.hi x.lo  y.hi y.lo -- x y )  swap bwjoin >r  swap bwjoin r>  ; 
    … …  
    3640      0 1 ts-b!                    ( okay? )  \ Set to polled mode 
    3741   then                            ( okay? ) 
    38    " dimensions" $call-screen  to screen-h  to screen-w 
     42   set-geometry 
    3943; 
    4044 
    41 : dimensions  ( -- w h )  screen-w  screen-h  ; 
     45: touched?  ( -- flag )  d# 99 gpio-pin@ 0=  ; 
     46: #touches  ( -- n )  h# 10 ts-b@   h# 7f and  ; 
    4247 
    43 : #contacts  ( -- n )  d# 10  ; 
    44  
    45 : pad-events  ( -- n*[ x.hi x.lo y.hi y.lo z ]  #contacts ) 
    46    d# 99 gpio-pin@  if  false exit  then 
    47    h# 10 ts-b@   h# 7f and  >r                        ( r: #contacts ) 
    48    r@  if                                             ( r: #contacts ) 
    49       h# 11 1  r@ 5 *  " smbus-out-in" $call-parent   ( n*[ x.hi x.lo y.hi y.lo z ]  r: #contacts ) 
    50    then                                               ( n*[ x.hi x.lo y.hi y.lo z ]  r: #contacts ) 
    51    r>                                                 ( n*[ x.hi x.lo y.hi y.lo z ]  #contacts ) 
     48: pad-events  ( -- n*[ x.hi x.lo y.hi y.lo z ]  #touches ) 
     49   touched? 0=  if  false exit  then 
     50   #touches >r  r@  if                                ( r: #touches ) 
     51      h# 11 1  r@ 5 *  " smbus-out-in" $call-parent   ( n*[ x.hi x.lo y.hi y.lo z ]  r: #touches ) 
     52   then                                               ( n*[ x.hi x.lo y.hi y.lo z ]  r: #touches ) 
     53   r>                                                 ( n*[ x.hi x.lo y.hi y.lo z ]  #touches ) 
    5254; 
    53  
    54 h# f800 constant red 
    55 h# 07e0 constant green 
    56 h# 001f constant blue 
    57 h# ffe0 constant yellow 
    58 h# f81f constant magenta 
    59 h# 07ff constant cyan 
    60 h# ffff constant white 
    61 h# 0000 constant black 
    62  
    63 variable pixcolor 
    64  
    65 h# 4 value y-offset 
    66 0 value /line 
    67 2 value /pixel 
    68  
    69  
    70 variable ptr 
    71  
    72 \ The following code receives and decodes touchpad packets 
    73  
    74 : show-packets  ( adr len -- ) 
    75    push-hex 
    76    bounds  ?do 
    77       i 6  bounds  ?do  i c@  3 u.r  loop  cr 
    78    6 +loop 
    79    pop-base 
    80 ; 
    81 : last-10  ( -- ) 
    82    ptr @  load-base -  d# 60  >  if 
    83       ptr @  d# 60 -  d# 60 
    84    else 
    85       load-base  ptr @  over - 
    86    then 
    87    show-packets 
    88 ; 
    89  
    90 : scale-xy  ( x y -- x' y' ) 
    91    swap screen-w touchscreen-max-x */ 
    92    swap screen-h touchscreen-max-y */ 
    93 ; 
    94  
    95 0 [if] 
    96 \ Try to receive a mouse report packet.  If one arrives within 
    97 \ 20 milliseconds, return true and the decoded information. 
    98 \ Otherwise return false. 
    99 : pad?  ( -- false | x y z down? contact# true ) 
    100    get-touch?   if            ( x dy buttons ) 
    101       2>r >r scale-xy r> 2r>  ( x' y' z down? contact# ) 
    102       true 
    103    else 
    104       false 
    105    then 
    106 ; 
    107  
    108 : flush  ( -- )  begin  d# 10 ms  pad?  while  2drop 3drop  repeat  ; 
    109  
    110 \ Display raw data from the device, stopping when a key is typed. 
    111 : show-pad  ( -- ) 
    112    begin 
    113       pad?  if  . . . . . cr  then 
    114    key? until 
    115 ; 
    116 [then] 
    11755 
    11856: close  ( -- ) 
    … …  
    12159; 
    12260 
    123 : button  ( color x -- ) 
    124    screen-h d# 50 -  d# 200  d# 30  fill-rectangle-noff 
    125 ; 
    126 d# 300 d# 300 2constant target-wh 
    127 : left-target   ( -- x y w h )  0 0  target-wh  ; 
    128 : right-target  ( -- x y w h )  screen-w screen-h  target-wh  xy-  target-wh  ; 
    129 false value left-hit? 
    130 false value right-hit? 
    131 : inside?  ( mouse-x,y  x y w h -- flag ) 
    132    >r >r         ( mouse-x mouse-y  x y  r: h w ) 
    133    xy-           ( dx dy ) 
    134    swap r> u<    ( dy x-inside? ) 
    135    swap r> u<    ( x-inside? y-inside? ) 
    136    and           ( flag ) 
    137 ; 
    138  
    139 : draw-left-target  ( -- )  green  left-target   fill-rectangle-noff  ; 
    140 : draw-right-target ( -- )  red    right-target  fill-rectangle-noff  ; 
    141  
    142 : ?hit-target  ( -- ) 
    143    pixcolor @  cyan =   if  \ touch1              ( x y ) 
    144       2dup  left-target  inside?  if              ( x y ) 
    145          yellow left-target  fill-rectangle-noff  ( x y ) 
    146          true to left-hit?                        ( x y ) 
    147          exit 
    148       then                                        ( x y ) 
    149    then                                           ( x y ) 
    150    pixcolor @ yellow =  if  \ touch2              ( x y ) 
    151       2dup  right-target  inside?  if             ( x y ) 
    152          yellow right-target  fill-rectangle-noff ( x y ) 
    153          true to right-hit?                       ( x y ) 
    154          exit 
    155       then                                        ( x y ) 
    156    then                                           ( x y ) 
    157 ; 
    158  
    159 : track-init  ( -- ) 
    160    screen-ih package( bytes/line )package  to /line 
    161    load-base ptr ! 
    162 ; 
    163  
    164 : dot  ( x y -- ) 
    165    swap screen-w 3 - min  swap y-offset + screen-h 3 - min  ( x' y' ) 
    166    pixcolor @  -rot   3 3                   ( color x y w h ) 
    167    fill-rectangle-noff                      ( ) 
    168 ; 
    169  
    170 : background  ( -- ) 
    171    black  0 0  screen-w screen-h  fill-rectangle-noff 
    172    final-test?  if 
    173       false to left-hit? 
    174       false to right-hit? 
    175       draw-left-target 
    176       draw-right-target 
    177    else 
    178       0 d# 27 at-xy  ." Touchscreen test.  Type a key to exit" cr 
    179    then 
    180 ; 
    181  
    182 : *3/5  ( n -- n' )  3 5 */  ; 
    183 : dimmer  ( color -- color' ) 
    184    565>rgb rot *3/5 rot *3/5 rot *3/5 rgb>565 
    185 ; 
    186  
    187 : setcolor  ( contact# -- ) 
    188    case 
    189       0  of  cyan    endof 
    190       1  of  yellow  endof 
    191       2  of  magenta endof 
    192       3  of  blue    endof 
    193       4  of  red     endof 
    194       5  of  green   endof 
    195       6  of  cyan    dimmer  endof 
    196       7  of  yellow  dimmer  endof 
    197       8  of  magenta dimmer  endof 
    198       9  of  blue    dimmer  endof 
    199   d# 10  of  red     dimmer  endof 
    200   d# 11  of  green   dimmer  endof 
    201       ( default )  white swap 
    202    endcase 
    203  
    204    pixcolor !          
    205 ; 
    206 0 value pressure 
    207  
    208 : track-n  ( .. xhi xlo yhi ylo z  #contacts -- ) 
    209    ?dup 0=  if  exit  then     ( .. xhi xlo yhi ylo z  #contacts -- ) 
     61: track-n  ( .. xhi xlo yhi ylo z  #touches -- ) 
     62   ?dup 0=  if  exit  then     ( .. xhi xlo yhi ylo z  #touches -- ) 
    21063   1-  0  swap  do             ( .. xhi xlo yhi ylo z ) 
    21164      i setcolor               ( .. xhi xlo yhi ylo z ) 
    … …  
    21366      4b>xy  scale-xy          ( .. x y ) 
    21467 
    215       final-test?  if          ( .. x y ) 
    216          ?hit-target           ( .. x y ) 
    217       then                     ( .. x y ) 
     68      targets?  if  ?hit-target   then     ( .. x y ) 
     69 
    21870      dot 
    21971   -1 +loop 
    22072; 
    22173 
    222 : handle-key  ( -- exit? ) 
    223    key upc  case 
    224       [char] P  of 
    225          cursor-on 
    226          cr last-10 
    227          key drop 
    228          background 
    229          false 
    230       endof 
    231  
    232       ( key )  true swap 
    233    endcase 
     740 0 2value last-xy 
     75false value last-down? 
     76: no-touch  ( -- false | x y buttons true ) 
     77   last-down?  if 
     78      \ Return up event for last "mouse" position 
     79      false to last-down? 
     80      last-xy 0 true 
     81   else 
     82      false 
     83   then 
    23484; 
    235  
    236 false value selftest-failed?  \ Success/failure flag for final test mode 
    237 : exit-test?  ( -- flag ) 
    238    final-test?  if                    ( ) 
    239       \ If the targets have been hit, we exit with successa 
    240       left-hit? right-hit? and  if    ( ) 
    241          false to selftest-failed?    ( ) 
    242          true                         ( flag ) 
    243          exit 
    244       then                            ( ) 
    245  
    246       \ Otherwise we give the tester a chance to bail out by typing a key, 
    247       \ thus indicating failure 
    248       key?  0=  if  false exit  then  ( ) 
    249       key drop                        ( ) 
    250       true to selftest-failed?        ( ) 
    251       true                            ( flag ) 
    252       exit 
    253    then                               ( ) 
    254  
    255    \ If not final test mode, we only exit via a key - no targets 
    256    key?  if  handle-key  else  false  then  ( exit ? ) 
     85: touch  ( -- false | x y buttons true ) 
     86   #touches  0=  if  false exit  then 
     87   h# 11 1 4  " smbus-out-in" $call-parent   ( x.hi x.lo y.hi y.lo ) 
     88   4b>xy  scale-xy     ( x y ) 
     89   2dup to last-xy     ( x y ) 
     90   true to last-down?  ( x y ) 
     91   1 true              ( x y buttons true ) 
    25792; 
    258  
     93: stream-poll?  ( -- false | x y buttons true ) 
     94   touched?  if  touch  else  no-touch  then 
     95; 
    25996: discard-n  ( .. #events -- )   5 *  0  ?do  drop  loop  ; 
    26097 
    … …  
    273110   then 
    274111 
    275    cursor-off  track-init 
     112   cursor-off 
    276113 
    277114   \ Consume already-queued keys to prevent premature exit 

  • cpu/x86/pc/olpc/via/mfgtest.fth

    r2890 r2893  
    156156 
    157157: init-menu  ( -- ) 
    158    ?open-screen  ?open-mouse 
     158   ?open-screen  ?open-mouse  ?open-touchscreen 
    159159   #mfgrows to rows 
    160160   #mfgcols to cols 

  • ofw/gui/dialog.fth

    r2331 r2893  
    201201   ['] selected?  find-node  nip       ( node ) 
    202202   " next-enum" run-method             ( ) 
     203; 
     204: get-key-code  ( -- c | c 9b ) 
     205   key  case 
     206      \ Distinguish between a bare ESC and an ESC-[ sequence 
     207      esc of 
     208         d# 10 ms  key?  if 
     209            key  [char] [ =  if  key csi  else  esc  then 
     210         else 
     211            esc 
     212         then 
     213      endof 
     214 
     215      csi of  key csi  endof 
     216      dup 
     217   endcase 
    203218; 
    204219: controls-key  ( list -- done? ) 

  • ofw/gui/graphics.fth

    r2755 r2893  
    2323 
    2424\needs screen-ih 0 value screen-ih 
    25 0 value mouse-ih 
    2625 
    2726: $call-screen  ( ??? adr len -- ??? )  screen-ih $call-method  ; 
    … …  
    5958; 
    6059 
    61 : get-event  ( #msecs -- false | x y buttons true ) 
    62    " get-event" mouse-ih $call-method 
    63 ; 
    64  
    6560: screen-color!  ( r g b color# -- )  " color!" $call-screen  ; 
    6661: screen-color@  ( color# -- r g b )  " color@" $call-screen  ; 

  • ofw/gui/iconmenu.fth

    r2876 r2893  
    2020\ keyboard input removes mouse cursor and moves mouse to selected square 
    2121\ keyboard input (arrows) always moves to an occupied square 
    22  
    23 \ need: 
    24 \ put text into square 
    25  
    26 \ have: 
    27 \ fill-rectangle ( color x y w h - )    color is 0..255 
    28 \ draw-rectangle ( address x y w h - )  address of 128x128 pixmap 
    29 \ read-rectangle ( address x y w h - ) 
    30 \ move-mouse-cursor ( x y - ) 
    31 \ remove-mouse-cursor ( - ) 
    32 \ poll-mouse  ( -- x y buttons ) 
    33 \ get-event  ( #msecs -- false | x y buttons true ) 
    3422 
    3523hex 
    … …  
    425413; 
    426414 
    427 : do-mouse  ( - ) 
     415: do-mouse  ( -- ) 
    428416   mouse-ih 0=  if  exit  then 
    429417   begin  mouse-event?  while         ( x y buttons ) 
    430       remove-mouse-cursor 
     418      remove-mouse-cursor             ( x y buttons ) 
    431419      -rot  update-position           ( buttons ) 
     420      new-sq? 
     421      draw-mouse-cursor 
     422   repeat 
     423; 
     424: do-touchscreen  ( -- ) 
     425   touchscreen-ih 0=  if  exit  then 
     426   begin  touchscreen-event?  while   ( x y buttons ) 
     427      remove-mouse-cursor             ( x y buttons ) 
     428      -rot  set-xy                    ( buttons ) 
    432429      new-sq? 
    433430      draw-mouse-cursor 
    … …  
    497494  
    498495   false to done? 
    499    begin   do-mouse  do-key   done? until 
     496   begin   do-touchscreen  do-mouse  do-key   done? until 
    500497   false to done? 
    501498  
    … …  
    567564\ when a root menu is defined. 
    568565headers 
     566 
    569567\ LICENSE_BEGIN 
    570568\ Copyright (c) 2006 FirmWorks 

  • ofw/gui/mouse.fth

    r2754 r2893  
    33 
    44headerless 
     5 
     60 value mouse-ih 
    57 
    68false value mouse-absolute?  \ True if coordinates are absolute 
    … …  
    156158: clamp  ( n min max - m )  rot min max  ; 
    157159 
     160: set-xy  ( x y -- )  to ypos  to xpos  ; 
    158161: update-position  ( x y -- ) 
    159    mouse-absolute?  if  to ypos  to xpos  exit  then 
     162   mouse-absolute?  if  set-xy  exit  then 
    160163   2dup or 0=  if  2drop exit  then  \ Avoid flicker if there is no movement 
    161164 
    … …  
    165168   negate  ypos +  0  max-y cursor-h -  clamp      ( x y' ) 
    166169   swap    xpos +  0  max-x cursor-w -  clamp      ( y' x') 
    167    to xpos  to ypos 
    168 ; 
    169  
    170 : get-key-code  ( -- c | c 9b ) 
    171    key  case 
    172       \ Distinguish between a bare ESC and an ESC-[ sequence 
    173       esc of 
    174          d# 10 ms  key?  if 
    175             key  [char] [ =  if  key csi  else  esc  then 
    176          else 
    177             esc 
    178          then 
    179       endof 
    180  
    181       csi of  key csi  endof 
    182       dup 
    183    endcase 
    184 ; 
     170   swap set-xy 
     171; 
     172 
    185173headers 
    186174 
    … …  
    214202: mouse-event?  ( -- false | x y buttons true ) 
    215203   " stream-poll?" mouse-ih $call-method 
     204; 
     205 
     2060 value touchscreen-ih 
     207 
     2080 value close-touchscreen? 
     209 
     210: ?close-touchscreen  ( -- ) 
     211   close-touchscreen?  if 
     212      touchscreen-ih close-dev 
     213      0 to touchscreen-ih 
     214      hardware-cursor?  if 
     215         false to hardware-cursor? 
     216         " cursor-off" $call-screen 
     217      then 
     218   then 
     219; 
     220: ?open-touchscreen  ( -- ) 
     221   touchscreen-ih  0=  dup to close-touchscreen?  if 
     222      " touchscreen" open-dev is touchscreen-ih 
     223      touchscreen-ih  0=  if 
     224         " /touchscreen" open-dev to touchscreen-ih 
     225      then 
     226   then 
     227; 
     228: touchscreen-event?  ( -- false | x y buttons true ) 
     229   " stream-poll?" touchscreen-ih $call-method 
    216230; 
    217231 

  • ofw/gui/textfld.fth

    r1 r2893  
    116116      then 
    117117      mouse-ih  if 
    118          begin  10 get-event  while 
     118         begin  mouse-event?  while 
    119119            remove-mouse-cursor 
    120120            -rot update-position 
Note: See TracChangeset for help on using the changeset viewer.