openfirmware

openfirmware@openfirmware.info

3007 discussions

[commit] r2753 - cpu/x86/pc/olpc
by repository service 08 Dec '11

08 Dec '11

Author: wmb Date: Thu Dec 8 13:43:38 2011 New Revision: 2753 URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2753 Log: OLPC MMP2 audio driver - don't insert volume controls into the nonexistent keyboard driver. Modified: cpu/x86/pc/olpc/sound.fth Modified: cpu/x86/pc/olpc/sound.fth ============================================================================== --- cpu/x86/pc/olpc/sound.fth Thu Dec 8 13:43:34 2011 (r2752) +++ cpu/x86/pc/olpc/sound.fth Thu Dec 8 13:43:38 2011 (r2753) @@ -54,6 +54,7 @@ close-audio ; +[ifndef] olpc-cl3 dev /keyboard 0 value waiting-up? : olpc-check-abort ( scan-code -- abort? ) \ an abort key pressed? @@ -83,6 +84,7 @@ ; ' handle-volume? to scan-handled? dend +[then] \ LICENSE_BEGIN \ Copyright (c) 2006 FirmWorks

1 0

[commit] r2752 - cpu/x86/pc/olpc
by repository service 08 Dec '11

08 Dec '11

Author: wmb Date: Thu Dec 8 13:43:34 2011 New Revision: 2752 URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2752 Log: OLPC GUI - more screen resolution adaptation. Modified: cpu/x86/pc/olpc/gui.fth Modified: cpu/x86/pc/olpc/gui.fth ============================================================================== --- cpu/x86/pc/olpc/gui.fth Thu Dec 8 13:43:29 2011 (r2751) +++ cpu/x86/pc/olpc/gui.fth Thu Dec 8 13:43:34 2011 (r2752) @@ -372,6 +372,10 @@ \ 88 is 1200 1024 - 2/ , 66 is 900 768 - 2/ \+ olpc-cl3 swap d# 88 - swap d# 66 - ( x' y' ) \ Recenter for XO-3 ; +: ?adjust-y ( y -- y' ) +\ 132 is 900 768 - +\+ olpc-cl3 d# 132 - ( x' y' ) \ Adjustment in Y only for bottom-relative +; : set-icon-xy ( x y -- ) ?adjust to icon-xy ; : show-going ( -- ) background-rgb rgb>565 progress-xy ?adjust d# 500 d# 100 " fill-rectangle" $call-screen @@ -380,9 +384,10 @@ ; : show-no-power ( -- ) \ chip, battery, overlaid sad face - d# 25 d# 772 set-icon-xy " spi" show-icon - d# 175 d# 772 set-icon-xy " battery" show-icon - d# 175 d# 790 set-icon-xy " sad" show-icon + \ Apply full Y adjustment for stuff at the bottom of the screen + d# 25 d# 772 ?adjust-y to icon-xy " spi" show-icon + d# 175 d# 772 ?adjust-y to icon-xy " battery" show-icon + d# 175 d# 790 ?adjust-y to icon-xy " sad" show-icon ; d# 834 value bar-y

1 0

[commit] r2751 - cpu/x86/pc/olpc
by repository service 08 Dec '11

08 Dec '11

Author: wmb Date: Thu Dec 8 13:43:29 2011 New Revision: 2751 URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2751 Log: Display selftest - auto-adapt to different screen resolutions. Modified: cpu/x86/pc/olpc/disptest.fth Modified: cpu/x86/pc/olpc/disptest.fth ============================================================================== --- cpu/x86/pc/olpc/disptest.fth Thu Dec 8 13:43:24 2011 (r2750) +++ cpu/x86/pc/olpc/disptest.fth Thu Dec 8 13:43:29 2011 (r2751) @@ -20,13 +20,15 @@ ; : .horizontal-bars16 ( -- ) dimensions ( width height ) + dup d# 16 / to bar-int ( height width ) 0 ?do ( width ) i test-color16 0 i 3 pick bar-int fill-rect bar-int +loop drop ; : .vertical-bars16 ( -- ) - dimensions ( width height ) - swap 0 ?do ( height ) + dimensions swap ( height width ) + dup d# 16 / to bar-int ( height width ) + 0 ?do ( height ) i test-color16 i 0 bar-int 4 pick fill-rect bar-int +loop drop ;

1 0

[commit] r2750 - cpu/arm/olpc
by repository service 08 Dec '11

08 Dec '11

Author: wmb Date: Thu Dec 8 13:43:24 2011 New Revision: 2750 URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2750 Log: OLPC XO-3.0 - Added touchscreen diag to graphical menu. Modified: cpu/arm/olpc/testitems.fth Modified: cpu/arm/olpc/testitems.fth ============================================================================== --- cpu/arm/olpc/testitems.fth Thu Dec 8 13:43:20 2011 (r2749) +++ cpu/arm/olpc/testitems.fth Thu Dec 8 13:43:24 2011 (r2750) @@ -8,6 +8,7 @@ icon: wifi.icon rom:wifi.565 icon: audio.icon rom:audio.565 \- olpc-cl3 icon: touchpad.icon rom:touchpad.565 +\+ olpc-cl3 icon: touchscreen.icon rom:touchpad.565 icon: display.icon rom:display.565 \- olpc-cl3 icon: keyboard.icon rom:keyboard.565 icon: timer.icon rom:timer.565 @@ -34,7 +35,8 @@ : camera-item ( -- ) " /camera" mfg-test-dev ; : wlan-item ( -- ) " /wlan" mfg-test-dev ; : timer-item ( -- ) " /timer" mfg-test-dev ; -\- olpc-cl3 : touchpad-item ( -- ) " mouse" mfg-test-dev ; +\- olpc-cl3 : touchpad-item ( -- ) " /touchpad" mfg-test-dev ; +\+ olpc-cl3 : touchscreen-item ( -- ) " /touchscreen" mfg-test-dev ; \- olpc-cl3 : keyboard-item ( -- ) " keyboard" mfg-test-dev ; : switch-item ( -- ) " /accelerometer" mfg-test-dev " /switches" mfg-test-dev ; : leds-item ( -- ) " /leds" mfg-test-dev ; @@ -91,6 +93,9 @@ \- olpc-cl3 " Touchpad" \- olpc-cl3 ['] touchpad-item touchpad.icon 3 2 install-icon +\+ olpc-cl3 " Touchscreen" +\+ olpc-cl3 ['] touchscreen-item touchscreen.icon 3 2 install-icon + " LEDs" ['] leds-item leds.icon 3 3 install-icon

1 0

[commit] r2749 - cpu/arm/olpc
by repository service 08 Dec '11

08 Dec '11

Author: wmb Date: Thu Dec 8 13:43:20 2011 New Revision: 2749 URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2749 Log: OLPC XO-3.0 - Invert mic sense. Modified: cpu/arm/olpc/sound.fth Modified: cpu/arm/olpc/sound.fth ============================================================================== --- cpu/arm/olpc/sound.fth Thu Dec 8 13:43:16 2011 (r2748) +++ cpu/arm/olpc/sound.fth Thu Dec 8 13:43:20 2011 (r2749) @@ -247,7 +247,10 @@ d# 96 constant external-mic : pin-sense? ( gpio# -- flag ) gpio-pin@ ; : headphones-inserted? ( -- flag ) headphone-jack pin-sense? ; -: microphone-inserted? ( -- flag ) external-mic pin-sense? ; +: microphone-inserted? ( -- flag ) + external-mic pin-sense? +\+ olpc-cl3 0= +; fload ${BP}/cpu/arm/olpc/alc5631.fth \ Realtek ALC5631Q CODEC [then]

1 0

[commit] r2748 - cpu/arm/olpc
by repository service 08 Dec '11

08 Dec '11

Author: wmb Date: Thu Dec 8 13:43:16 2011 New Revision: 2748 URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2748 Log: OLPC XO-3.0 - SDHCI/eMMC power doesn't involve a GPIO on this platform. Modified: cpu/arm/olpc/sdhci.fth Modified: cpu/arm/olpc/sdhci.fth ============================================================================== --- cpu/arm/olpc/sdhci.fth Thu Dec 8 13:43:12 2011 (r2747) +++ cpu/arm/olpc/sdhci.fth Thu Dec 8 13:43:16 2011 (r2748) @@ -15,10 +15,19 @@ ' olpc-card-inserted? to card-inserted? \ Slot:power_GPIO - 1:35, 2:34, 3:33 - : gpio-power-on ( -- ) sdhci-card-power-on d# 36 slot - gpio-set ; + : gpio-power-on ( -- ) + sdhci-card-power-on +\ The CL3 version below actually works for CL2 >= B1 +\+ olpc-cl2 d# 36 slot - gpio-set +\+ olpc-cl3 slot 2 = if d# 34 gpio-set then + ; ' gpio-power-on to card-power-on - : gpio-power-off ( -- ) d# 36 slot - gpio-clr sdhci-card-power-off ; + : gpio-power-off ( -- ) +\+ olpc-cl2 d# 36 slot - gpio-clr +\+ olpc-cl3 slot 2 = if d# 34 gpio-clr then + sdhci-card-power-off + ; ' gpio-power-off to card-power-off \+ olpc-cl2 new-device

1 0

[commit] r2747 - cpu/arm/olpc
by repository service 08 Dec '11

08 Dec '11

Author: wmb Date: Thu Dec 8 13:43:12 2011 New Revision: 2747 URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2747 Log: EXC7200 touchscreen driver - mouse compatibility. Modified: cpu/arm/olpc/exc7200-touchscreen.fth Modified: cpu/arm/olpc/exc7200-touchscreen.fth ============================================================================== --- cpu/arm/olpc/exc7200-touchscreen.fth Thu Dec 8 13:43:07 2011 (r2746) +++ cpu/arm/olpc/exc7200-touchscreen.fth Thu Dec 8 13:43:12 2011 (r2747) @@ -4,13 +4,37 @@ 0 0 " 4,8" " /twsi" begin-package my-space encode-int my-address encode-int encode+ " reg" property " touchscreen" name + +0 value screen-w +0 value screen-h + : open ( -- okay? ) my-unit " set-address" $call-parent true \ Read once to prime the interrupt d# 10 " get" $call-parent 4drop 4drop 2drop + " dimensions" $call-screen to screen-h to screen-w ; : close ( -- ) ; -: get-touch? ( -- false | x y z down? contact# true ) + +h# 7fff constant touchscreen-max-x +h# 7fff constant touchscreen-max-y + +: invert-x ( x -- x' ) touchscreen-max-x swap - ; +: invert-y ( y -- y' ) touchscreen-max-y swap - ; + +: scale-x ( x -- x' ) + invert-x + screen-w touchscreen-max-x */ +; +: scale-y ( y -- y' ) + invert-y + screen-h touchscreen-max-y */ +; + +\ Try to receive a mouse report packet. If one arrives within +\ 20 milliseconds, return true and the decoded information. +\ Otherwise return false. +: pad? ( -- false | x y z down? contact# true ) d# 99 gpio-pin@ if false exit then d# 10 " get" $call-parent ( 4 flags xlo xhi ylo yhi zlo zhi 0 0 ) 2drop bwjoin >r bwjoin >r bwjoin >r ( 4 flags r: z y x ) @@ -21,12 +45,26 @@ r> r> r> 4drop false exit ( -- false ) then ( flags r: z y x ) - r> r> r> 3 roll ( x y z flags ) + r> scale-x ( flags x' r: z y ) + r> scale-y ( flags x y' r: z ) + + r> 3 roll ( x y z flags ) dup 1 and 0<> ( x y z flags down? ) swap 2 rshift h# 1f and ( x y z down? contact# ) true ( x y z down? contact# true ) ; - +true value absolute? +: stream-poll? ( -- false | x y buttons true ) + pad? if ( x y z down? contact# ) + 0= if ( x y z down? ) + nip 1 and true ( x y buttons true ) + else ( x y z down? ) + 4drop false ( false ) + then ( false | x y buttons true ) + else ( ) + false ( false ) + then ( false | x y buttons true ) +; h# f800 constant red h# 07e0 constant green @@ -40,10 +78,8 @@ variable pixcolor h# 4 value y-offset -0 value screen-w -0 value screen-h -0 value /line -2 value /pixel +\ 0 value /line +\ 2 value /pixel variable ptr @@ -66,30 +102,6 @@ show-packets ; -h# 7fff constant touchscreen-max-x -h# 7fff constant touchscreen-max-y - -: invert-x ( x y -- x' y ) touchscreen-max-x rot - swap ; -: invert-y ( x y -- x y' ) touchscreen-max-y swap - ; - -: scale-xy ( x y -- x' y' ) - invert-x invert-y - swap screen-w touchscreen-max-x */ - swap screen-h touchscreen-max-y */ -; - -\ Try to receive a mouse report packet. If one arrives within -\ 20 milliseconds, return true and the decoded information. -\ Otherwise return false. -: pad? ( -- false | x y z down? contact# true ) - get-touch? if ( x dy buttons ) - 2>r >r scale-xy r> 2r> ( x' y' z down? contact# ) - true - else - false - then -; - \ Display raw data from the device, stopping when a key is typed. : show-pad ( -- ) begin @@ -133,9 +145,10 @@ then ( x y ) ; +: targets? ( -- flag ) true ; \ Used to be "final-test?" + : track-init ( -- ) - " dimensions" $call-screen to screen-h to screen-w - screen-ih package( bytes/line )package to /line +\ screen-ih package( bytes/line )package to /line load-base ptr ! ; @@ -147,13 +160,13 @@ : background ( -- ) black 0 0 screen-w screen-h fill-rectangle-noff - final-test? if + targets? if false to left-hit? false to right-hit? draw-left-target draw-right-target else - 0 d# 27 at-xy ." Touchscreen test. Type a key to exit" cr + 0 d# 27 at-xy ." Touchscreen test. Hit both targets to exit" cr then ; @@ -185,7 +198,7 @@ \ dup 5 and 5 = if background load-base ptr ! then - final-test? if ( x y ) + targets? if ( x y ) ?hit-target ( x y ) then ( x y ) @@ -208,7 +221,7 @@ false value selftest-failed? \ Success/failure flag for final test mode : exit-test? ( -- flag ) - final-test? if ( ) + targets? if ( ) \ If the targets have been hit, we exit with successa left-hit? right-hit? and if ( ) false to selftest-failed? ( ) @@ -236,6 +249,8 @@ then ; +: flush-touchpad ( -- ) begin pad? while 2drop 3drop repeat ; + : selftest ( -- error? ) open 0= if ." Touchscreen open failed" true exit @@ -248,7 +263,7 @@ \ Being able to open the touchpad is good enough in SMT mode smt-test? if close false exit then - final-test? 0= if + targets? 0= if ." Touchscreen test will start in 4 seconds" cr d# 4000 ms then @@ -259,7 +274,7 @@ begin key? while key drop repeat \ Consume already-queued trackpad events to prevent premature exit - begin pad? while 2drop 3drop repeat + flush-touchpad background begin @@ -267,10 +282,12 @@ if track then exit-test? until + flush-touchpad + close cursor-on page - final-test? if selftest-failed? else false then + targets? if selftest-failed? else false then ;

1 0

[commit] r2746 - cpu/arm/olpc/3.0 dev/usb2/hcd/ehci
by repository service 08 Dec '11

08 Dec '11

Author: wmb Date: Thu Dec 8 13:43:07 2011 New Revision: 2746 URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2746 Log: USB EHCI driver - support low and full speed devices connected to EHCI controller, as some EHCI controllers can handle them without needing a companion controller. Modified: cpu/arm/olpc/3.0/usb.fth dev/usb2/hcd/ehci/probe.fth Modified: cpu/arm/olpc/3.0/usb.fth ============================================================================== --- cpu/arm/olpc/3.0/usb.fth Thu Dec 8 13:43:02 2011 (r2745) +++ cpu/arm/olpc/3.0/usb.fth Thu Dec 8 13:43:07 2011 (r2746) @@ -16,6 +16,11 @@ : otg-set-host-mode 3 h# a8 ehci-reg! ; \ Force host mode ' otg-set-host-mode to set-host-mode + \ The Marvell EHCI can handle low and full speed devices directly, + \ without needing a UHCI or OHCI companion controller + ' make-port-node to handle-ls-device + ' make-port-node to handle-fs-device + : sleep ( -- ) true to first-open? ; : wake ( -- ) ; end-package @@ -33,11 +38,17 @@ fload ${BP}/dev/usb2/hcd/ehci/loadpkg.fth \ false to delay? \ No need for a polling delay on this platform + \ The Marvell EHCI can handle low and full speed devices directly, + \ without needing a UHCI or OHCI companion controller + ' make-port-node to handle-ls-device + ' make-port-node to handle-fs-device + : sleep ( -- ) true to first-open? ; : wake ( -- ) ; end-package -\ Turn on USB power after a delay, to ensure that USB devices are reset correctly on boot +\ usb-power-on is unnecessary on initial boot, as CForth turns on the +\ USB power during its GPIO setup. : usb-power-on ( -- ) d# 126 gpio-clr \ OTG 5V on d# 127 gpio-clr \ ULPI 5V on @@ -56,7 +67,7 @@ ; stand-init: Init USB Phy -\ usb-power-on \ The EC now controls the USB power +\ usb-power-on \ The USB power is turned on early, when CForth sets up GPIOs init-usb ; @@ -118,17 +129,24 @@ alias p2 probe-usb 0 value usb-keyboard-ih +0 value otg-keyboard-ih : attach-usb-keyboard ( -- ) " usb-keyboard" expand-alias if ( devspec$ ) drop " /usb" comp 0= if ( ) " usb-keyboard" open-dev to usb-keyboard-ih usb-keyboard-ih add-input - exit then else ( devspec$ ) 2drop then + + " otg/keyboard" expand-alias if ( devspec$ ) + open-dev to otg-keyboard-ih + otg-keyboard-ih add-input + else + 2drop + then ; : detach-usb-keyboard ( -- ) Modified: dev/usb2/hcd/ehci/probe.fth ============================================================================== --- dev/usb2/hcd/ehci/probe.fth Thu Dec 8 13:43:02 2011 (r2745) +++ dev/usb2/hcd/ehci/probe.fth Thu Dec 8 13:43:07 2011 (r2746) @@ -4,13 +4,15 @@ hex headers +0 value port-speed + : make-root-hub-node ( port -- ) \ Some devices (e.g. Lexar USB-to-SD) fail unless you get the cfg desc from device 0 first 0 set-target \ First address it as device 0 ( port ) - speed-high 0 di-speed! \ Use high speed for getting the device descriptor + port-speed 0 di-speed! \ Use high speed for getting the device descriptor dev-desc-buf h# 40 get-cfg-desc drop ( port ) - speed-high ( port speed ) + port-speed ( port speed ) \ hub-port and hub-dev route USB 1.1 transactions through USB 2.0 hubs over get-hub20-port get-hub20-dev ( port speed hub-port hub-dev ) @@ -21,22 +23,31 @@ 0 instance value probe-error? \ Back channel to selftest +: make-port-node ( port -- ) + ['] make-root-hub-node catch if + drop ." Failed to make root hub node for port " dup .d cr + true to probe-error? + then +; +defer handle-ls-device ' disown-port to handle-ls-device +defer handle-fs-device ' disown-port to handle-fs-device + : probe-root-hub-port ( port -- ) false to probe-error? ( port ) dup disable-old-nodes ( port ) dup portsc@ 1 and 0= if drop exit then ( port ) \ No device detected dup portsc@ h# c00 and h# 400 = if \ A low speed device detected - dup disown-port \ Disown the port + speed-low to port-speed + dup handle-ls-device \ Process low-speed device else \ Don't know what it is dup reset-port \ Reset to find out dup portsc@ 4 and 0= if \ A full speed device detected - dup disown-port \ Disown the port + speed-full to port-speed + dup handle-fs-device \ Process full-speed device else \ A high speed device detected - dup ['] make-root-hub-node catch if \ Process high speed device - drop ." Failed to make root hub node for port " dup .d cr - true to probe-error? - then + speed-high to port-speed + dup make-port-node \ Process high-speed device then then ( port# ) dup portsc@ swap portsc! ( ) \ Clear connection change bit

1 0

[commit] r2745 - dev/usb2/hcd
by repository service 08 Dec '11

08 Dec '11

Author: wmb Date: Thu Dec 8 13:43:02 2011 New Revision: 2745 URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2745 Log: USB - reset port before set-address - fixes some instances of "failed to set target address". Modified: dev/usb2/hcd/device.fth Modified: dev/usb2/hcd/device.fth ============================================================================== --- dev/usb2/hcd/device.fth Thu Dec 8 13:42:57 2011 (r2744) +++ dev/usb2/hcd/device.fth Thu Dec 8 13:43:02 2011 (r2745) @@ -453,6 +453,7 @@ tuck di-speed! ( port dev ) 0 set-target ( port dev ) \ Address it as device 0 + over reset-port ( port dev ) \ Some devices want to be reset here dup set-address if ( port dev ) \ Assign it usb addr dev ." Retrying with a delay" cr over reset-port d# 5000 ms

1 0

[commit] r2744 - dev
by repository service 08 Dec '11

08 Dec '11

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

1 0

Jump to page:

2025

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

openfirmware