Author: wmb Date: Thu Dec 8 13:42:57 2011 New Revision: 2744 URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2744
Log: On-screen keyboard initial revision.
Added: dev/softkeyboard.fth
Added: dev/softkeyboard.fth ============================================================================== --- /dev/null 00:00:00 1970 (empty, because file is newly added) +++ dev/softkeyboard.fth Thu Dec 8 13:42:57 2011 (r2744) @@ -0,0 +1,433 @@ +purpose: Interactive keyboard test shows which keys are pressed +\ See license at end of file + +dev /touchscreen +new-device + +" keyboard" device-name + +hex + +struct + /w field >key-x + /w field >key-y + /w field >key-w + /w field >key-h + /c field >key-code1 + /c field >key-code2 +constant /key + +/key d# 128 * buffer: keys + +0 value #keys +0 value key-y +0 value key-x + +d# 8 constant key-gap +d# 10 constant row-gap +d# 0 constant hidden-key-w +d# 60 constant smulti-key-w +d# 60 constant single-key-w +d# 60 constant single-key-h +d# 90 constant shift-key-w +d# 460 constant space-key-w +d# 340 constant top-row-offset +d# 34 constant button-w +d# 34 constant button-h + +: key-adr ( i -- adr ) /key * keys + ; + +0 value codes1 +0 value codes2 +: set-codes ( adr2 len2 adr1 len1 -- ) drop to codes1 drop to codes2 ; +: set-key-code ( key -- ) + key-adr ( 'key ) + codes1 c@ over >key-code1 c! 1 codes1 + to codes1 + codes2 c@ swap >key-code2 c! 1 codes2 + to codes2 +; + +: top-key-row ( -- ) top-row-offset to key-y key-gap to key-x ; +: next-key-row ( -- ) + key-y single-key-h + row-gap + to key-y + key-gap to key-x +; +: #keys++ ( -- ) #keys 1+ to #keys ; +: ++key-x ( n -- ) key-x + to key-x ; +: add-key-gap ( -- ) key-gap ++key-x ; +: (make-key) ( x y w h -- ) + #keys key-adr >r + r@ >key-h w! r@ >key-w w! r@ >key-y w! r@ >key-x w! + r> drop + #keys set-key-code + #keys++ +; +: make-key ( w -- ) dup key-x key-y rot single-key-h (make-key) ++key-x ; +: make-key&gap ( w -- ) make-key add-key-gap ; +: make-single-key ( -- ) single-key-w make-key&gap ; +: blank-single-key ( -- ) single-key-w ++key-x add-key-gap ; +: make-smulti-key ( i -- ) + 1 and if + hidden-key-w make-key + else + smulti-key-w make-key + then +; +: make-double-key ( -- ) single-key-w 2* make-key&gap ; +: make-shift-key ( -- ) shift-key-w make-key&gap ; +: make-space-key ( -- ) space-key-w make-key&gap ; +: make-quad-key ( -- ) + key-x key-y single-key-w 2* dup >r single-key-h 2* row-gap + (make-key) + r> ++key-x + add-key-gap +; +0 [if] +: make-button ( x y -- ) button-w button-h (make-key) ; + +: make-buttons + d# 68 d# 25 make-button \ Rocker up 65 + d# 25 d# 68 make-button \ Rocker left 67 + d# 110 d# 68 make-button \ Rocker right 68 + d# 68 d# 110 make-button \ Rocker down 66 + d# 68 d# 196 make-button \ Rotate 69 + + d# 918 d# 25 make-button \ O e0 65 + d# 875 d# 68 make-button \ square e0 67 + d# 960 d# 68 make-button \ check e0 68 + d# 918 d# 110 make-button \ X e0 66 +; +[then] + +: make-keys ( -- ) + 0 to #keys + top-key-row +\ " "(1b)" +\ " "(1b)" set-codes +\ make-single-key + + next-key-row + " ~!@#$%^&*()_+"b" + " '1234567890-="b" set-codes + d# 13 0 do make-single-key loop + make-double-key + next-key-row + " "tQWERTYUIOP{}"r" + " "tqwertyuiop[]"r" set-codes + d# 13 0 do make-single-key loop + make-quad-key + + next-key-row + " "(80)ASDFGHJKL:""|" + " "(80)asdfghjkl;'" set-codes + d# 13 0 do make-single-key loop + + next-key-row + " "(81)ZXCVBNM<>?"(8186)" \ 86 may be unused + " "(81)zxcvbnm,./"(8182)" set-codes \ 82 may be unused + make-shift-key + d# 10 0 do make-single-key loop + make-shift-key +\ make-single-key \ Omit up arrow for now + + next-key-row + " "(1b) "(878889)" + " "(1b) "(838485)" set-codes + make-single-key + 2 0 do blank-single-key loop + make-space-key + 2 0 do blank-single-key loop +\ 3 0 do make-single-key loop \ Omit arrows for now + +\ make-buttons +; + +: bounded? ( n lower size -- flag ) bounds swap within ; + +: inside? ( tx ty x y w h -- flag ) + >r ( tx ty x y w r: h ) + swap >r ( tx ty x w r: h y ) + rot >r ( tx x w r: h y ty ) + bounded? if ( r: h y ty ) + r> r> r> bounded? ( flag ) + else ( r: h y ty ) + r> r> r> 3drop ( ) + false ( flag ) + then ( flag ) +; +: >key-bounds ( 'key -- x y w h ) + >r r@ >key-x w@ r@ >key-y w@ r@ >key-w w@ r> >key-h w@ +; +: key-hit? ( x y key# -- ) + key-adr >key-bounds inside? +; +: find-key? ( x y -- false | key# true ) + #keys 0 do ( x y ) + 2dup i key-hit? if ( x y ) + 2drop i true ( key# true ) + unloop exit ( -- key# true ) + then ( x y ) + loop ( x y ) + 2drop false ( false ) +; + +\ 80 ctrl 81 shift +\ 82 up 83 left 84 down 85 right +\ 86 pg up 87 home 88 pg dn 89 end + +h# f81f constant down-key-color +h# 07ff constant tested-key-color +h# 001f constant idle-key-color +h# ffff constant kbd-bc + +0 value esc? + +: key-inset ( dx dy 'key -- x y ) + >key-bounds 2drop ( dx dy x y ) + rot + >r + r> ( x y ) +; +: string-label ( adr len 'key -- ) + d# 15 d# 25 rot key-inset ( adr len x y ) + type-at-xy ( ) +; +: special-label? ( char -- flag ) h# 20 h# 7e between 0= ; +: special-label ( char 'key -- ) + >r ( char r: 'key ) + case + h# 08 of " Backspace" r> string-label endof + h# 09 of " Tab" r> string-label endof + h# 1b of " Esc" r> string-label endof + h# 80 of " Ctrl" r> string-label endof + h# 81 of " Shift" r> string-label endof + h# 0d of " Enter" d# 35 d# 55 r> key-inset type-at-xy endof + ( default ) r> drop + endcase +; +: label-key ( color 'key -- ) + >r to char-bg kbd-bc to char-fg ( r: 'key ) + r@ >key-code2 c@ ( char r: 'key ) + dup special-label? if ( char r: 'key ) + r> special-label exit ( ) + then ( char r: 'key ) + dup [char] A [char] Z between if ( letter r: 'key ) + d# 10 d# 10 r> key-inset ( char x y ) + character-at-xy ( ) + else ( char r: 'key ) + d# 40 d# 10 r@ key-inset ( char x y r: 'key ) + character-at-xy ( r: 'key ) + r@ >key-code1 c@ ( char x y r: 'key ) + d# 25 d# 35 r> key-inset ( char x y ) + character-at-xy ( ) + then +; +: draw-key ( key# color -- ) + swap key-adr >r ( color r: 'key ) + r@ >key-w w@ hidden-key-w = if ( color r: 'key ) + r> 2drop ( ) + else ( color r: 'key ) + dup r@ >key-bounds ( color x y w h r: 'key ) + " fill-rectangle" $call-screen ( color r: 'key ) + r> label-key ( ) + then +; + +0 value ctrl? +0 value shift? + +: get-ascii? ( key# -- false | ascii true ) + key-adr ( 'key ) + shift? if >key-code2 else >key-code1 then c@ ( code ) + + dup h# 80 >= if ( code ) + case + h# 80 of true to ctrl? endof + h# 81 of true to shift? endof + \ Rest are reserved + endcase + false exit ( -- false ) + then ( code ) + + ctrl? if ( code ) + dup h# 40 h# 7f between if ( code ) + h# 1f and true ( ascii true ) + else ( code ) + drop false ( false ) + then ( false | ascii true ) + exit ( -- false | ascii true ) + then ( code ) + + true +; +: cancel-shifts ( key# -- ) + key-adr >key-code1 c@ ( code ) + case + h# 80 of false to ctrl? endof + h# 81 of false to shift? endof + \ Rest are reserved + endcase +; + +: key-down ( key# -- ) down-key-color draw-key ; +: key-up ( key# -- ) + dup cancel-shifts + idle-key-color draw-key +; + +: fill-screen ( color -- ) + 0 0 " dimensions" $call-screen " fill-rectangle" $call-screen +; + +struct + /n field >contact-time + /n field >contact-key# +constant /contact + +d# 10 /contact * buffer: contacts + +: >contact ( contact# -- 'contact ) /contact * contacts + ; +: cancel-contact ( contact# -- ) >contact >contact-key# off ; +: get-contact-key#? ( contact# -- false | key# true ) + >contact >contact-key# @ ( n ) + dup if 1- true then ( false | key# true ) +; +: set-contact-key# ( contact# key# -- ) + 1+ swap ( key#' contact# ) + >contact >contact-key# ! ( ) +; + +d# 100 value short \ Auto-repeat interval in ms +d# 1000 value long \ Initial auto-repeat interval in ms + +: set-repeat ( contact# interval -- ) + get-msecs + ( adr ascii contact# new-time ) + swap >contact >contact-time ! ( adr ascii contact# new-time ) +; +: get-repeat ( contact# -- time ) >contact >contact-time @ ; + +\ Records the contact and returns the key code if there is one +: return-key-code ( adr contact# key# -- -1 | 1 ) + over long set-repeat ( adr contact# key# ) \ Set repeat time + tuck set-contact-key# ( adr key# ) \ Remember key + get-ascii? if ( adr ascii ) + swap c! 1 ( 1 ) + else ( adr ) + \ There was no ASCII code - probably it was ctrl or shift - + \ so nothing to return. + drop -1 ( -1 ) + then ( 1 | -1 ) +; + +\ Called when a finger is still down in the same key area as before. +\ Repeats the key code when the time is right. +: ?repeated ( adr contact# key# -- ) + get-ascii? if ( adr contact# ascii ) + swap dup get-repeat ( adr ascii contact# time ) + get-msecs - 0<= if ( adr ascii contact# ) + short set-repeat ( adr ascii ) + swap c! 1 ( 1 ) + else ( adr ascii contact# ) + 3drop -1 ( -1 ) + then ( 1 | -1 ) + else ( adr ) + \ No code value, so no need to auto-repeat + drop -1 ( -1 ) + then ( 1 | -1 ) +; + +: press-key ( adr x y contact# -- 1 | -1 ) + -rot find-key? if ( adr contact# key# ) + \ The event happened in a key area + over get-contact-key#? if ( adr contact# key# old-key# ) + \ Continued press + 2dup = if ( adr contact# key# old-key# ) + \ Same - check for auto-repeat + drop ( adr contact# key# ) + ?repeated ( -1 | 1 ) + else ( adr contact# key# old-key# ) + \ Different - release old key and activate new one + key-up ( adr contact# key# ) + dup key-down ( adr contact# key# ) + return-key-code ( -1 | 1 ) + then ( -1 | 1 ) + else ( adr contact# key# ) + \ New keypress + dup key-down ( adr contact# key# ) + return-key-code ( 1 ) + then + else ( adr contact# ) + \ The event happened outside a key area + dup get-contact-key#? if ( adr contact# old-key# ) + \ Moved out of key area - release key + key-up ( adr contact# ) + cancel-contact ( adr ) + drop -1 ( -1 ) + else ( adr contact# ) + \ Press in blank area with nothing down + 2drop -1 ( -1 ) + then ( -1 ) + then ( 1 | -1 ) +; + +: release-key ( adr x y contact# -- -1 ) + dup get-contact-key#? if ( adr x y contact# key# ) + key-up ( adr x y contact# ) + then ( adr x y contact# ) + cancel-contact ( adr x y ) + 3drop -1 ( -1 ) +; + +: read ( adr len -- actual | -1) + 0= if drop -1 exit then ( adr ) + " pad?" $call-parent 0= if ( adr ) + drop -1 exit ( -- -1 ) + then ( adr x y z down? contact# ) + rot drop swap if ( adr x y contact# ) + press-key ( 1 | -1 ) + else ( adr x y contact# ) + release-key ( -1 ) + then ( 1 | -1 ) +; +: poller ( -- ) + begin here 1 read 0> if here c@ emit then ukey? until +; + +: draw-keyboard ( -- ) + kbd-bc fill-screen + #keys 0 ?do i key-up loop +; + +: open ( -- okay? ) + false exit +\ save-background + make-keys + draw-keyboard + true +; +: close ( -- ) +\ restore-background +; + +finish-device +device-end + +\ LICENSE_BEGIN +\ Copyright (c) 2007 FirmWorks +\ +\ Permission is hereby granted, free of charge, to any person obtaining +\ a copy of this software and associated documentation files (the +\ "Software"), to deal in the Software without restriction, including +\ without limitation the rights to use, copy, modify, merge, publish, +\ distribute, sublicense, and/or sell copies of the Software, and to +\ permit persons to whom the Software is furnished to do so, subject to +\ the following conditions: +\ +\ The above copyright notice and this permission notice shall be +\ included in all copies or substantial portions of the Software. +\ +\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +\ +\ LICENSE_END