Ported to 0.79
Eduardo Cavazos
parent
288f987f12
commit
9df7d54982
|
|
@ -1,12 +1,28 @@
|
|||
|
||||
IN: factory
|
||||
|
||||
USING: kernel namespaces generic math sequences hashtables io vectors words
|
||||
USING: kernel namespaces generic math sequences hashtables io arrays words
|
||||
prettyprint lists concurrency
|
||||
xlib x concurrent-widgets simple-error-handler ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
DEFER: workspace-menu
|
||||
DEFER: wm-frame?
|
||||
DEFER: manage-window
|
||||
DEFER: window-list
|
||||
DEFER: refresh-window-list
|
||||
DEFER: layout-frame
|
||||
DEFER: mapped-windows
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: popup-window ( -- ) mouse-sensor move-window raise-window map-window ;
|
||||
|
||||
: popup-window% [ popup-window ] with-window-object ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: root-menu
|
||||
|
||||
: setup-root-menu ( -- )
|
||||
|
|
@ -16,7 +32,9 @@ SYMBOL: root-menu
|
|||
"xlogo" [ "launch program..." print ] root-menu get add-popup-menu-item
|
||||
"xclock" [ "launch program..." print ] root-menu get add-popup-menu-item
|
||||
"xload" [ "launch program..." print ] root-menu get add-popup-menu-item
|
||||
"emacs" [ "launch program..." print ] root-menu get add-popup-menu-item ;
|
||||
"emacs" [ "launch program..." print ] root-menu get add-popup-menu-item
|
||||
"Workspaces"
|
||||
[ workspace-menu get popup-window% ] root-menu get add-popup-menu-item ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -97,13 +115,10 @@ TUPLE: wm-root ;
|
|||
dup
|
||||
[ swap drop ]
|
||||
[ drop >r dpy get r> <window> ]
|
||||
ifte ;
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
DEFER: wm-frame?
|
||||
DEFER: manage-window
|
||||
|
||||
M: wm-root handle-map-request-event ( event <wm-root> -- )
|
||||
drop XMapRequestEvent-window id>obj ! obj
|
||||
|
||||
|
|
@ -155,17 +170,17 @@ M: wm-root move-request-x ( event wm-root -- x )
|
|||
dup move-request-x?
|
||||
[ XConfigureRequestEvent-x ]
|
||||
[ XConfigureRequestEvent-window [ window-x ] with-win ]
|
||||
ifte ;
|
||||
if ;
|
||||
|
||||
M: wm-root move-request-y ( event wm-root -- y )
|
||||
drop
|
||||
dup move-request-y?
|
||||
[ XConfigureRequestEvent-y ]
|
||||
[ XConfigureRequestEvent-window [ window-y ] with-win ]
|
||||
ifte ;
|
||||
if ;
|
||||
|
||||
M: wm-root move-request-position ( event wm-root -- { x y } )
|
||||
2dup move-request-x -rot move-request-y 2vector ;
|
||||
2dup move-request-x -rot move-request-y 2array ;
|
||||
|
||||
M: wm-root execute-move-request ( event wm-root -- )
|
||||
dupd move-request-position swap XConfigureRequestEvent-window move-window+ ;
|
||||
|
|
@ -177,17 +192,17 @@ M: wm-root size-request-width ( event wm-root -- width )
|
|||
dup size-request-width?
|
||||
[ XConfigureRequestEvent-width ]
|
||||
[ XConfigureRequestEvent-window [ window-width ] with-win ]
|
||||
ifte ;
|
||||
if ;
|
||||
|
||||
M: wm-root size-request-height ( event wm-root -- height )
|
||||
drop
|
||||
dup size-request-height?
|
||||
[ XConfigureRequestEvent-height ]
|
||||
[ XConfigureRequestEvent-window [ window-height ] with-win ]
|
||||
ifte ;
|
||||
if ;
|
||||
|
||||
M: wm-root size-request-size ( event wm-root -- { width height } )
|
||||
2dup size-request-width -rot size-request-height 2vector ;
|
||||
2dup size-request-width -rot size-request-height 2array ;
|
||||
|
||||
M: wm-root execute-size-request ( event wm-root -- )
|
||||
dupd size-request-size swap XConfigureRequestEvent-window resize-window+ ;
|
||||
|
|
@ -203,9 +218,6 @@ M: wm-root handle-configure-request-event ( event wm-root -- )
|
|||
! M: wm-root handle-button-press-event
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
DEFER: window-list
|
||||
DEFER: refresh-window-list
|
||||
|
||||
M: wm-root handle-button-press-event ( event wm-root -- )
|
||||
drop ! event
|
||||
|
||||
|
|
@ -215,7 +227,7 @@ M: wm-root handle-button-press-event ( event wm-root -- )
|
|||
root-menu get raise-window%
|
||||
root-menu get map-window% ]
|
||||
[ root-menu get unmap-window% ]
|
||||
ifte ] }
|
||||
if ] }
|
||||
|
||||
{ [ dup XButtonEvent-button Button2 = ]
|
||||
[ window-list get window-map-state% IsUnmapped =
|
||||
|
|
@ -224,7 +236,7 @@ M: wm-root handle-button-press-event ( event wm-root -- )
|
|||
window-list get refresh-window-list
|
||||
window-list get map-window% ]
|
||||
[ window-list get unmap-window% ]
|
||||
ifte ] } }
|
||||
if ] } }
|
||||
|
||||
cond ;
|
||||
|
||||
|
|
@ -332,7 +344,7 @@ TUPLE: wm-frame child ;
|
|||
|
||||
M: wm-frame handle-destroy-window-event ( event <wm-frame> -- )
|
||||
2dup destroy-window-event-match?
|
||||
[ destroy-window% drop ] [ drop drop ] ifte ;
|
||||
[ destroy-window% drop ] [ drop drop ] if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -341,7 +353,7 @@ M: wm-frame handle-destroy-window-event ( event <wm-frame> -- )
|
|||
|
||||
M: wm-frame handle-map-request-event ( event <wm-frame> -- )
|
||||
2dup map-request-event-match? ! event frame ?
|
||||
[ dup wm-frame-child map-window% map-window% drop ] [ drop drop ] ifte ;
|
||||
[ dup wm-frame-child map-window% map-window% drop ] [ drop drop ] if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -350,7 +362,7 @@ M: wm-frame handle-map-request-event ( event <wm-frame> -- )
|
|||
|
||||
M: wm-frame handle-map-event ( event <wm-frame> -- )
|
||||
2dup map-event-match?
|
||||
[ dup map-window% raise-window% drop ] [ drop drop ] ifte ;
|
||||
[ dup map-window% raise-window% drop ] [ drop drop ] if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! M: wm-frame handle-configure-request-event ( event frame )
|
||||
|
|
@ -360,16 +372,16 @@ M: wm-frame move-request-x ( event frame -- x )
|
|||
over move-request-x?
|
||||
[ drop XConfigureRequestEvent-x ]
|
||||
[ nip window-x% ]
|
||||
ifte ;
|
||||
if ;
|
||||
|
||||
M: wm-frame move-request-y ( event frame -- y )
|
||||
over move-request-y?
|
||||
[ drop XConfigureRequestEvent-y ]
|
||||
[ nip window-y% ]
|
||||
ifte ;
|
||||
if ;
|
||||
|
||||
M: wm-frame move-request-position ( event frame -- { x y } )
|
||||
2dup move-request-x -rot move-request-y 2vector ;
|
||||
2dup move-request-x -rot move-request-y 2array ;
|
||||
|
||||
M: wm-frame execute-move-request ( event frame )
|
||||
dup -rot move-request-position swap move-window% ;
|
||||
|
|
@ -380,16 +392,16 @@ M: wm-frame size-request-width ( event frame -- width )
|
|||
over size-request-width?
|
||||
[ drop XConfigureRequestEvent-width ]
|
||||
[ nip wm-frame-child window-width% ]
|
||||
ifte ;
|
||||
if ;
|
||||
|
||||
M: wm-frame size-request-height ( event frame -- height )
|
||||
over size-request-height?
|
||||
[ drop XConfigureRequestEvent-height ]
|
||||
[ nip wm-frame-child window-height% ]
|
||||
ifte ;
|
||||
if ;
|
||||
|
||||
M: wm-frame size-request-size ( event frame -- size )
|
||||
2dup size-request-width -rot size-request-height 2vector ;
|
||||
2dup size-request-width -rot size-request-height 2array ;
|
||||
|
||||
: execute-size-request/child ( event frame )
|
||||
dup wm-frame-child -rot size-request-size swap resize-window% ;
|
||||
|
|
@ -413,12 +425,10 @@ M: wm-frame handle-configure-request-event ( event frame )
|
|||
wm-frame-child window-id swap XUnmapEvent-window = ;
|
||||
|
||||
M: wm-frame handle-unmap-event ( event frame )
|
||||
2dup unmap-event-match? [ unmap-window% drop ] [ drop drop ] ifte ;
|
||||
2dup unmap-event-match? [ unmap-window% drop ] [ drop drop ] if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
DEFER: layout-frame
|
||||
|
||||
: drag-move-frame ( frame -- ) drag-move-window% ;
|
||||
|
||||
: drag-resize-frame ( frame -- ) dup drag-resize-window% layout-frame ;
|
||||
|
|
@ -437,7 +447,7 @@ M: wm-frame handle-enter-window-event ( event frame )
|
|||
nip dup wm-frame-child valid-window?%
|
||||
[ wm-frame-child >r RevertToPointerRoot CurrentTime r> set-input-focus% ]
|
||||
[ destroy-window% ]
|
||||
ifte ;
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -454,6 +464,52 @@ M: wm-frame handle-property-event ( event frame )
|
|||
swap resize-window% ! frame
|
||||
drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Workspaces
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
GENERIC: switch-to
|
||||
|
||||
SYMBOL: current-workspace
|
||||
|
||||
TUPLE: workspace windows ;
|
||||
|
||||
: create-workspace [ ] <workspace> ;
|
||||
|
||||
M: workspace switch-to ( workspace -- )
|
||||
mapped-windows dup current-workspace get set-workspace-windows
|
||||
[ unmap-window+ ] each
|
||||
dup workspace-windows [ map-window+ ] each
|
||||
current-workspace set ;
|
||||
|
||||
SYMBOL: workspace-1
|
||||
SYMBOL: workspace-2
|
||||
SYMBOL: workspace-3
|
||||
SYMBOL: workspace-4
|
||||
|
||||
create-workspace workspace-1 set
|
||||
create-workspace workspace-2 set
|
||||
create-workspace workspace-3 set
|
||||
create-workspace workspace-4 set
|
||||
|
||||
workspace-1 get current-workspace set
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: workspace-menu
|
||||
|
||||
: setup-workspace-menu ( -- )
|
||||
create-menu workspace-menu set
|
||||
"black" lookup-color workspace-menu get set-window-background%
|
||||
"Workspace 1"
|
||||
[ workspace-1 get switch-to ] workspace-menu get add-popup-menu-item
|
||||
"Workspace 2"
|
||||
[ workspace-2 get switch-to ] workspace-menu get add-popup-menu-item
|
||||
"Workspace 3"
|
||||
[ workspace-3 get switch-to ] workspace-menu get add-popup-menu-item
|
||||
"Workspace 4"
|
||||
[ workspace-4 get switch-to ] workspace-menu get add-popup-menu-item ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! window-list
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -471,7 +527,7 @@ SYMBOL: window-list
|
|||
wm-frame-child ! window-list frame child
|
||||
fetch-name% ! window-list frame name-or-f
|
||||
dup ! window-list frame name-or-f name-or-f
|
||||
[ ] [ drop "*untitled*" ] ifte ! window-list frame name
|
||||
[ ] [ drop "*untitled*" ] if ! window-list frame name
|
||||
swap ! window-list name frame
|
||||
[ map-window% ] ! window-list name frame [ map-window% ]
|
||||
cons ! window-list name action
|
||||
|
|
@ -505,5 +561,6 @@ SYMBOL: window-list
|
|||
root get create-wm-root
|
||||
setup-root-menu
|
||||
setup-window-list
|
||||
setup-workspace-menu
|
||||
manage-existing-windows
|
||||
[ concurrent-event-loop ] spawn ;
|
||||
|
|
@ -3,7 +3,7 @@
|
|||
IN: automata
|
||||
|
||||
USING: parser kernel hashtables namespaces sequences lists math io
|
||||
threads strings vectors prettyprint xlib x ;
|
||||
threads strings arrays prettyprint xlib x ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! set-rule
|
||||
|
|
@ -11,6 +11,8 @@ USING: parser kernel hashtables namespaces sequences lists math io
|
|||
|
||||
SYMBOL: rule
|
||||
|
||||
8 <hashtable> rule set
|
||||
|
||||
SYMBOL: char-0
|
||||
|
||||
48 char-0 set
|
||||
|
|
@ -27,7 +29,7 @@ SYMBOL: char-0
|
|||
|
||||
: rule-values ( n -- { ... } )
|
||||
>bin 8 char-0 get pad-left
|
||||
>vector
|
||||
>array
|
||||
[ 48 - ] map ;
|
||||
|
||||
: set-rule ( n -- )
|
||||
|
|
@ -40,15 +42,15 @@ SYMBOL: char-0
|
|||
: 3nth ( n seq -- slice ) >r dup 3 + r> <slice> ;
|
||||
|
||||
: next-chunk ( << slice: a b c >> - value )
|
||||
>vector rule get hash ;
|
||||
>array rule get hash ;
|
||||
|
||||
: (step) ( line -- new-line )
|
||||
dup length 2 - [ swap 3nth next-chunk ] map-with ;
|
||||
|
||||
: step-line ( line -- new-line )
|
||||
>r { 0 } r> { 0 } append append
|
||||
(step) ;
|
||||
|
||||
: (step) ( line -- new-line )
|
||||
dup length 2 - [ swap 3nth next-chunk ] map-with ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Display the rule
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -64,7 +66,7 @@ SYMBOL: char-0
|
|||
|
||||
: random-line ( -- line )
|
||||
0 400 <range>
|
||||
[ drop 0 1 random-int ]
|
||||
[ drop 2 random-int ]
|
||||
map ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -72,13 +74,13 @@ SYMBOL: char-0
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: show-point ( { x y } p -- )
|
||||
1 = [ draw-point ] [ drop ] ifte ;
|
||||
1 = [ draw-point ] [ drop ] if ;
|
||||
|
||||
: (show-line) ( { x y } line -- )
|
||||
[ >r dup r> show-point { 1 0 } v+ ] each drop ;
|
||||
|
||||
: show-line ( y line -- )
|
||||
>r >r 0 r> 2vector r> (show-line) ;
|
||||
>r >r 0 r> 2array r> (show-line) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Go
|
||||
|
|
@ -95,7 +97,7 @@ SYMBOL: char-0
|
|||
flush-dpy ;
|
||||
|
||||
: random-gallery
|
||||
1 255 random-int
|
||||
255 random-int 1 +
|
||||
dup unparse print
|
||||
set-rule
|
||||
run-rule
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
IN: boids
|
||||
|
||||
USING: namespaces math kernel sequences vectors xlib x ;
|
||||
USING: namespaces math kernel sequences arrays xlib x ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -38,18 +38,22 @@ SYMBOL: time-slice 0.5 time-slice set
|
|||
! random-boid and random-boids
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: random-n ( n -- random-0-to-n-1 )
|
||||
1 - 0 swap random-int ;
|
||||
! : random-range dupd swap - random-int + ;
|
||||
|
||||
: random-range ( a b -- n ) 1 + dupd swap - random-int + ;
|
||||
|
||||
! : random-n ( n -- random-0-to-n-1 )
|
||||
! 1 - 0 swap random-int ;
|
||||
|
||||
: random-pos ( -- pos )
|
||||
world-size get [ random-n ] map ;
|
||||
world-size get [ random-int ] map ;
|
||||
|
||||
: random-vel ( -- vel )
|
||||
2 >vector [ drop -10 10 random-int ] map ;
|
||||
2 >array [ drop -10 10 random-range ] map ;
|
||||
|
||||
: random-boid ( -- boid ) random-pos random-vel <boid> ;
|
||||
|
||||
: random-boids ( n -- boids ) >vector [ drop random-boid ] map ;
|
||||
: random-boids ( n -- boids ) >array [ drop random-boid ] map ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -179,7 +183,7 @@ SYMBOL: boids
|
|||
normalize
|
||||
separation-weight get
|
||||
v*n ]
|
||||
ifte ;
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -192,7 +196,7 @@ SYMBOL: boids
|
|||
normalize
|
||||
alignment-weight get
|
||||
v*n ]
|
||||
ifte ;
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -207,7 +211,7 @@ SYMBOL: boids
|
|||
normalize
|
||||
cohesion-weight get
|
||||
v*n ]
|
||||
ifte ;
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -248,7 +252,7 @@ SYMBOL: boids
|
|||
|
||||
: wrap-pos ( pos -- pos )
|
||||
[ ] each
|
||||
wrap-y swap wrap-x swap 2vector ;
|
||||
wrap-y swap wrap-x swap 2array ;
|
||||
|
||||
: iterate-boid ( self -- self )
|
||||
dup >r new-pos wrap-pos r> new-vel <boid> ;
|
||||
|
|
|
|||
|
|
@ -229,7 +229,7 @@ TUPLE: menu item-width item-height space ;
|
|||
! dup ! event obj-or-f obj-or-f
|
||||
! [ handle-event ]
|
||||
! [ drop drop ] ! event obj-or-f obj-or-f [ handle-event ] [ drop drop ]
|
||||
! ifte
|
||||
! if
|
||||
! event-loop ;
|
||||
|
||||
! It's possible to have multiple displays open simultaneously.
|
||||
|
|
@ -241,7 +241,7 @@ TUPLE: menu item-width item-height space ;
|
|||
QueuedAfterFlush events-queued 0 >
|
||||
[ next-event ]
|
||||
[ 100 sleep concurrent-next-event ]
|
||||
ifte ;
|
||||
if ;
|
||||
|
||||
: concurrent-event-loop ( -- )
|
||||
concurrent-next-event ! event
|
||||
|
|
@ -252,7 +252,7 @@ TUPLE: menu item-width item-height space ;
|
|||
dup ! event obj-or-f obj-or-f
|
||||
[ handle-event ]
|
||||
[ drop drop ] ! event obj-or-f obj-or-f [ handle-event ] [ drop drop ]
|
||||
ifte
|
||||
if
|
||||
concurrent-event-loop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -293,4 +293,8 @@ TUPLE: menu item-width item-height space ;
|
|||
|
||||
: vertical-layout% [ vertical-layout ] with-window-object ;
|
||||
|
||||
: draw-string% [ draw-string ] with-window-object ;
|
||||
: draw-string% [ draw-string ] with-window-object ;
|
||||
|
||||
: get-transient-for-hint% [ get-transient-for-hint ] with-window-object ;
|
||||
|
||||
: fetch-name% [ fetch-name ] with-window-object ;
|
||||
|
|
@ -1,20 +1,20 @@
|
|||
|
||||
IN: x
|
||||
|
||||
USING: kernel math vectors namespaces sequences xlib x rectangle ;
|
||||
USING: kernel math arrays namespaces sequences xlib x rectangle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: text-width ( string -- width ) font get swap dup length XTextWidth ;
|
||||
|
||||
: string-size ( string -- size ) text-width font get font-height 2vector ;
|
||||
: string-size ( string -- size ) text-width font get font-height 2array ;
|
||||
|
||||
: string-rect ( string -- rect ) string-size { 0 0 } swap <rect> ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: base-point ( rect -- )
|
||||
top-left font get XFontStruct-ascent 0 swap 2vector v+ ;
|
||||
top-left font get XFontStruct-ascent 0 swap 2array v+ ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
|
||||
IN: x USING: namespaces kernel math vectors alien sequences xlib ;
|
||||
IN: x USING: namespaces kernel math arrays alien sequences xlib ;
|
||||
|
||||
SYMBOL: dpy
|
||||
SYMBOL: scr
|
||||
|
|
@ -72,10 +72,10 @@ DEFER: with-win
|
|||
>r dpy get win get r> [ ] each XResizeWindow drop ;
|
||||
|
||||
: set-window-width ( width -- )
|
||||
window-height 2vector resize-window ;
|
||||
window-height 2array resize-window ;
|
||||
|
||||
: set-window-height ( height -- )
|
||||
window-width swap 2vector resize-window ;
|
||||
window-width swap 2array resize-window ;
|
||||
|
||||
: set-window-border-width ( width -- )
|
||||
>r dpy get win get r> XSetWindowBorderWidth drop ;
|
||||
|
|
@ -112,7 +112,7 @@ DEFER: with-win
|
|||
|
||||
: window-size ( -- { width height } )
|
||||
dpy get win get 0 <Window> 0 <int> 0 <int>
|
||||
0 <uint> 0 <uint> 2dup 2vector >r
|
||||
0 <uint> 0 <uint> 2dup 2array >r
|
||||
0 <uint> 0 <uint>
|
||||
XGetGeometry drop r> [ *uint ] map ;
|
||||
|
||||
|
|
@ -122,7 +122,7 @@ DEFER: with-win
|
|||
|
||||
: window-position ( -- { x y } )
|
||||
dpy get win get 0 <Window>
|
||||
0 <int> 0 <int> 2dup 2vector >r
|
||||
0 <int> 0 <int> 2dup 2array >r
|
||||
0 <uint> 0 <uint> 0 <uint> 0 <uint>
|
||||
XGetGeometry drop r> [ *int ] map ;
|
||||
|
||||
|
|
@ -218,6 +218,18 @@ DEFER: with-win
|
|||
: ungrab-pointer ( time -- )
|
||||
>r dpy get r> XUngrabPointer drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! 14 - Inter-Client Communication Functions
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: fetch-name ( -- name-or-f )
|
||||
dpy get win get 0 <int> <void*> dup >r XFetchName drop r>
|
||||
dup *void* alien-address 0 = [ drop f ] [ *char* ] if ;
|
||||
|
||||
: get-transient-for-hint ( -- win-or-f )
|
||||
dpy get win get 0 <Window> dup >r XGetTransientForHint r>
|
||||
swap 0 = [ drop f ] [ *Window ] if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Not Categorized Yet
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -232,6 +244,9 @@ DEFER: with-win
|
|||
: center-window-horizontally+ [ center-window-horizontally ] with-win ;
|
||||
: window-children+ [ window-children ] with-win ;
|
||||
: window-map-state+ [ window-map-state ] with-win ;
|
||||
: destroy-window+ [ destroy-window ] with-win ;
|
||||
: map-window+ [ map-window ] with-win ;
|
||||
: unmap-window+ [ unmap-window ] with-win ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -284,7 +299,7 @@ DEFER: with-win
|
|||
|
||||
: mouse-sensor ( -- { root-x root-y } )
|
||||
dpy get win get 0 <Window> 0 <Window> 0 <int> 0 <int> 2dup >r >r
|
||||
0 <int> 0 <int> 0 <uint> XQueryPointer drop r> *int r> *int 2vector ;
|
||||
0 <int> 0 <int> 0 <uint> XQueryPointer drop r> *int r> *int 2array ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Windows and their children
|
||||
|
|
|
|||
Loading…
Reference in New Issue