steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Keyboard input and cleanups for X11 backend

slava 2006-03-22 07:07:21 +00:00
parent df8d0b7013
commit d22a142935
16 changed files with 161 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
library/cocoa/ui.factor
View File

@ -53,24 +53,18 @@ H{ } clone views set-global
{ 124 "RIGHT" }
{ 125 "DOWN" }
{ 126 "UP" }
} hash ;
: modifier ( mod -- seq )
modifiers
[ second swap bitand 0 > ] subset-with
[ first ] map ;
} ;
: key-code ( event -- string )
dup [keyCode] key-codes
dup [keyCode] key-codes hash
[ ] [ [charactersIgnoringModifiers] CF>string ] ?if ;
: event>binding ( event -- binding )
dup [modifierFlags] modifier swap key-code
[ add >list ] [ drop f ] if* ;
: event>gesture ( event -- gesture )
dup [modifierFlags] modifiers modifier swap key-code
add >list ;
: send-key-event ( view event -- )
>r view world-focus r> dup event>binding
[ pick handle-gesture ] [ t ] if*
>r view world-focus r> dup event>gesture pick handle-gesture
[ [characters] CF>string swap user-input ] [ 2drop ] if ;
"NSOpenGLView" "FactorView" {
@ -165,8 +159,8 @@ H{ } clone views set-global
IN: gadgets
: draw-handle ( handle -- )
1 [setNeedsDisplay:] ;
: redraw-world ( handle -- )
world-handle 1 [setNeedsDisplay:] ;
: in-window ( gadget status dim title -- )
>r <world> r> <FactorWindow> drop ;

2
library/help/help.factor
View File

@ -17,3 +17,5 @@ DEFER: $heading
: glossary ( name -- ) <term> help ;
: handbook ( -- ) "handbook" help ;
: tutorial ( -- ) "tutorial" help ;

3
library/syntax/see.factor
View File

@ -117,9 +117,6 @@ M: word class. drop ;
newline
] with-pprint ;
: completions ( substring words -- seq )
[ word-name subseq? ] subset-with ;
: apropos ( substring -- )
all-words completions natural-sort
[ [ synopsis ] keep simple-object terpri ] each ;

4
library/ui/backend.factor
View File

@ -1,7 +1,9 @@
IN: gadgets
USING: kernel opengl ;
DEFER: draw-handle ( handle -- )
DEFER: draw-world ! defined in world.factor
: redraw-world ( world -- ) draw-world ;
DEFER: in-window ( gadget status dim title -- )

12
library/ui/hand.factor
View File

@ -77,6 +77,10 @@ V{ } clone hand-buttons set-global
: request-focus ( gadget -- )
dup focusable-child swap find-world request-focus* ;
: modifier ( mod modifiers -- seq )
[ second swap bitand 0 > ] subset-with
[ first ] map ;
: drag-loc ( -- loc )
hand-loc get-global hand-click-loc get-global v- ;
@ -114,14 +118,18 @@ V{ } clone hand-buttons set-global
drop
] [
deque dup layout
find-world [ world-handle dup set ] when*
find-world [ dup world-handle set ] when*
layout-queued
] if ;
: init-ui ( -- )
H{ } clone \ timers set-global
<queue> \ invalid set-global ;
: ui-step ( -- )
do-timers
[ layout-queued ] make-hash
[ drop [ draw-handle ] when* ] hash-each
[ nip [ draw-world ] when* ] hash-each
10 sleep ;
: close-world ( world -- )

6
library/ui/launchpad.factor
View File

@ -1,6 +1,7 @@
IN: gadgets-launchpad
USING: gadgets gadgets-buttons gadgets-labels gadgets-layouts
gadgets-listener io kernel memory namespaces sequences ;
gadgets-listener help inspector io kernel memory namespaces
sequences ;
: <launchpad> ( menu -- )
[ first2 >r <label> r> <bevel-button> ] map make-pile
@ -9,6 +10,9 @@ gadgets-listener io kernel memory namespaces sequences ;
: default-launchpad
{
{ "Listener" [ listener-window ] }
{ "Documentation" [ [ handbook ] in-browser ] }
{ "Tutorial" [ [ tutorial ] in-browser ] }
{ "Vocabularies" [ [ vocabs. ] in-browser ] }
{ "Save image" [ save ] }
{ "Exit" [ 0 exit ] }
} <launchpad> ;

2
library/ui/layouts.factor
View File

@ -12,8 +12,6 @@ IN: gadgets-layouts
: invalid ( -- queue ) \ invalid get-global ;
<queue> \ invalid set-global
: add-invalid ( gadget -- ) invalid enque ;
: relayout ( gadget -- )

4
library/ui/line-editor.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: line-editor
USING: kernel math namespaces prettyprint sequences strings
vectors ;
USING: kernel math namespaces sequences strings vectors words ;
SYMBOL: history
SYMBOL: history-index
@ -146,6 +145,7 @@ M: document-elt prev-elt* 3drop 0 ;
2drop f
] [
line-text get subseq possibilities get completions
[ word-name ] map
] if ;
: complete ( completion -- )

52
library/ui/listener.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005 Slava Pestov.
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets-listener
USING: arrays compiler gadgets gadgets-editors gadgets-labels
@ -8,7 +8,7 @@ inference inspector io jedit kernel listener lists math
namespaces parser prettyprint sequences shells threads words
help ;
SYMBOL: stack-bar
TUPLE: listener-gadget pane stack status ;
: in-browser ( quot -- )
make-pane <scroller> "Browser" simple-window ; inline
@ -19,9 +19,8 @@ SYMBOL: stack-bar
: usable-words ( -- words )
use get hash-concat hash-values ;
: word-completion ( -- )
usable-words [ word-name ] map
pane get pane-input set-possibilities ;
: word-completion ( pane -- )
usable-words swap pane-input set-possibilities ;
: show-stack ( seq pack -- )
dup clear-gadget [
@ -33,22 +32,23 @@ SYMBOL: stack-bar
] if
] with-stream* ;
: ui-listener-hook ( -- )
datastack-hook get call stack-bar get show-stack
word-completion ;
: ui-listener-hook ( listener -- )
[
>r datastack-hook get call r>
listener-gadget-stack show-stack
] keep
listener-gadget-pane word-completion ;
: help-button
"Please read the " write { "handbook" } $link "." print ;
: listener-thread
pane get [
[ ui-listener-hook ] listener-hook set
help-button
listener
: listener-thread ( listener -- )
dup listener-gadget-pane [
[ ui-listener-hook ] curry listener-hook set
print-banner listener
] with-stream* ;
: <status-bar> ( -- gadget ) "" <label> dup status-theme ;
: <stack-bar> ( -- gadget ) <shelf> dup status-theme ;
: <bottom-bar> ( -- gadget status )
<status-bar> [
<shelf> dup stack-bar set-global
@ -58,13 +58,17 @@ SYMBOL: stack-bar
: <scroller> ( -- gadget )
<input-pane> dup pane set-global <scroller> ;
: <listener> ( -- gadget status )
<frame>
<input-pane> dup pane set-global <scroller>
over @center frame-add
<bottom-bar> >r over @bottom frame-add r> ;
C: listener-gadget ( -- gadget )
<frame> over set-delegate
<input-pane> dup pick set-listener-gadget-pane
<scroller> over @center frame-add
<status-bar> dup pick set-listener-gadget-status
over @bottom frame-add
<stack-bar> dup pick set-listener-gadget-stack
over @top frame-add ;
: listener-window ( -- )
<listener> { 600 700 0 } "Listener" in-window
[ clear listener-thread ] in-thread
pane get request-focus ;
<listener-gadget> dup dup listener-gadget-status
{ 600 700 0 } "Listener" in-window
[ >r clear r> listener-thread ] in-thread
listener-gadget-pane request-focus ;

4
library/ui/theme.factor
View File

@ -83,6 +83,4 @@ USING: arrays gadgets kernel sequences styles ;
{ "monospace" bold 12 } swap set-label-font ;
: status-theme ( label -- )
dup reverse-video-theme
{ 1.0 1.0 1.0 1.0 } over set-label-color
{ "monospace" plain 12 } swap set-label-font ;
T{ solid f { 0.9 0.95 1.0 1.0 } } swap set-gadget-interior ;

2
library/ui/timers.factor
View File

@ -16,8 +16,6 @@ GENERIC: tick ( ms object -- )
: timers \ timers get-global ;
H{ } clone \ timers set-global
: add-timer ( object delay -- )
over >r <timer> r> timers set-hash ;

3
library/words.factor
View File

@ -97,3 +97,6 @@ M: word literalize <wrapper> ;
: gensym ( -- word )
[ "G:" % \ gensym counter # ] "" make
f <word> dup init-word ;
: completions ( substring words -- seq )
[ word-name subseq? ] subset-with ;

24
library/x11/events.factor
View File

@ -2,9 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: x11
USING: alien arrays errors gadgets hashtables io kernel math
namespaces prettyprint sequences threads ;
GENERIC: expose-event ( event window -- )
namespaces prettyprint sequences strings threads ;
GENERIC: resize-event ( event window -- )
@ -14,7 +12,9 @@ GENERIC: button-up-event ( event window -- )
GENERIC: motion-event ( event window -- )
GENERIC: key-event ( event window -- )
GENERIC: key-down-event ( event window -- )
GENERIC: key-up-event ( event window -- )
GENERIC: client-event ( event window -- )
@ -35,12 +35,12 @@ GENERIC: client-event ( event window -- )
: handle-event ( event window -- )
over XAnyEvent-type {
{ [ dup Expose = ] [ drop expose-event ] }
{ [ dup ConfigureNotify = ] [ drop resize-event ] }
{ [ dup ButtonPress = ] [ drop button-down-event ] }
{ [ dup ButtonRelease = ] [ drop button-up-event ] }
{ [ dup MotionNotify = ] [ drop motion-event ] }
{ [ dup KeyPress = ] [ drop key-event ] }
{ [ dup KeyPress = ] [ drop key-down-event ] }
{ [ dup KeyRelease = ] [ drop key-up-event ] }
{ [ dup ClientMessage = ] [ drop client-event ] }
{ [ t ] [ 3drop ] }
} cond ;
@ -48,3 +48,15 @@ GENERIC: client-event ( event window -- )
: event-loop ( -- )
wait-event dup XAnyEvent-window windows get hash dup
[ handle-event ] [ 2drop ] if event-loop ;
: char-array>string ( n <char-array> -- string )
swap >string [ swap char-nth ] map-with ;
: buf-size 100 ;
: lookup-string ( event -- keysym string )
buf-size "char" <c-array> [
buf-size 0 <KeySym>
[ f XLookupString ] keep
*KeySym swap
] keep char-array>string ;

68
library/x11/ui.factor
View File

@ -3,14 +3,13 @@
IN: x11
USING: arrays errors freetype gadgets gadgets-launchpad
gadgets-layouts gadgets-listener hashtables kernel
kernel-internals math namespaces opengl sequences x11 ;
kernel-internals lists math namespaces opengl sequences
strings x11 ;
! In the X11 backend, world-handle is a pair { window context }.
! The window is an X11 window ID, and the context is a
! GLX context pointer.
M: world expose-event ( event world -- ) nip draw-world ;
M: world resize-event ( event world -- )
>r
dup XConfigureEvent-width swap XConfigureEvent-height 0
@ -27,7 +26,58 @@ M: world motion-event ( event world -- )
>r dup XMotionEvent-x swap XMotionEvent-y 0 3array r>
move-hand ;
M: world key-event ( event world -- ) 2drop ;
: modifiers
{
{ "SHIFT" HEX: 1 }
{ "CTRL" HEX: 4 }
{ "ALT" HEX: 8 }
} ;
: key-codes
H{
{ HEX: FF08 "BACKSPACE" }
{ HEX: FF09 "TAB" }
{ HEX: FF0D "RETURN" }
{ HEX: FF1B "ESCAPE" }
{ HEX: FFFF "DELETE" }
{ HEX: FF50 "HOME" }
{ HEX: FF51 "LEFT" }
{ HEX: FF52 "UP" }
{ HEX: FF53 "RIGHT" }
{ HEX: FF54 "DOWN" }
{ HEX: FF55 "PAGE_UP" }
{ HEX: FF56 "PAGE_DOWN" }
{ HEX: FF57 "END" }
{ HEX: FF58 "BEGIN" }
} ;
: ignored-key? ( keycode -- ? )
{
HEX: FFE1 HEX: FFE2 HEX: FFE3 HEX: FFE4 HEX: FFE5
HEX: FFE6 HEX: FFE7 HEX: FFE8 HEX: FFE9 HEX: FFEA
HEX: FFEB HEX: FFEC HEX: FFED HEX: FFEE
} member? ;
: key-code ( event -- keycode )
lookup-string drop dup ignored-key? [
drop f
] [
dup key-codes hash [ ] [ ch>string ] ?if
] if ;
: event>gesture ( event -- gesture )
dup XKeyEvent-state modifiers modifier
swap key-code [ add >list ] [ drop f ] if* ;
M: world key-down-event ( event world -- )
world-focus over event>gesture [
over handle-gesture
[ over lookup-string nip swap user-input ] [ 2drop ] if
] [
drop
] if* ;
M: world key-up-event ( event world -- ) 2drop ;
: close-box? ( event -- )
dup XClientMessageEvent-type "WM_PROTOCOLS" x-atom =
@ -42,16 +92,13 @@ M: world client-event ( event world -- )
] if ;
: gadget-window ( world -- window )
dup rect-dim first2 choose-visual [
create-window 2dup map-window*
] keep create-context 2array swap set-world-handle ;
[ dup rect-dim glx-window* dupd 2array ] keep
set-world-handle ;
IN: gadgets
: draw-handle ( handle -- ) first windows get hash draw-world ;
: in-window ( gadget status dim title -- )
>r <world> r> drop gadget-window ;
>r <world> gadget-window r> swap set-title ;
: select-gl-context ( handle -- )
dpy get swap first2 glXMakeCurrent
@ -65,6 +112,7 @@ IN: shells
: ui ( -- )
[
f [
init-ui
launchpad-window
listener-window
event-loop

20
library/x11/windows.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
IN: x11
USING: alien hashtables kernel math namespaces ;
USING: alien hashtables kernel math namespaces sequences ;
: create-window-mask ( -- n )
CWBackPixel CWBorderPixel bitor
@ -12,7 +12,7 @@ USING: alien hashtables kernel math namespaces ;
XCreateColormap ;
: event-mask ( -- n )
StructureNotifyMask ExposureMask bitor
StructureNotifyMask
KeyPressMask bitor
KeyReleaseMask bitor
ButtonPressMask bitor
@ -32,23 +32,23 @@ USING: alien hashtables kernel math namespaces ;
[ XVisualInfo-visual create-window-mask ] keep
window-attributes XCreateWindow ;
: glx-window ( dim -- window context )
first2 choose-visual [ create-window ] keep create-context ;
: destroy-window ( win -- )
dpy get swap XDestroyWindow drop ;
: destroy-window* ( win -- )
dup windows get remove-hash destroy-window ;
: map-window ( win -- )
dpy get swap XMapWindow drop ;
: map-window ( win -- ) dpy get swap XMapWindow drop ;
: map-window* ( world win -- )
[ windows get set-hash ] keep map-window ;
: map-subwindows ( win -- )
dpy get swap XMapSubwindows drop ;
: glx-window* ( world dim -- win context )
glx-window >r [ map-window* ] keep r> ;
: unmap-window ( win -- )
dpy get swap XUnmapWindow drop ;
: unmap-window ( win -- ) dpy get swap XUnmapWindow drop ;
: unmap-subwindows ( win -- )
dpy get swap XUnmapSubwindows drop ;
: set-title ( string win -- ) dpy get -rot swap XStoreName drop ;

15
library/x11/xlib.factor
View File

@ -46,9 +46,17 @@ TYPEDEF: ulong Time
TYPEDEF: void* Window**
: False 0 ;
: True 1 ;
: <ulong> <uint> ;
: <XID> <ulong> ;
: <Window> <XID> ;
: <Drawable> <XID> ;
: <KeySym> <XID> ;
: *ulong *uint ;
: *XID *ulong ;
: *Window *XID ;
: *Drawable *XID ;
: *KeySym *XID ;
!
! 2 - Display Functions
!
@ -1306,3 +1314,6 @@ FUNCTION: Status XSetStandardProperties (
: PropModeReplace 0 ; inline
: PropModePrepend 1 ; inline
: PropModeAppend 2 ; inline
! The rest of the stuff is not from the book.
FUNCTION: int XStoreName ( Display* display, Window w, char* window_name ) ;