Merge branch 'master' of git://factorcode.org/git/factor
commit
47d5c24597
basis
extra
faq
furnace
html/templates/chloe
springies/ui
x/widgets/wm/workspace
|
@ -24,10 +24,10 @@ TUPLE: pasteboard handle ;
|
|||
C: <pasteboard> pasteboard
|
||||
|
||||
M: pasteboard clipboard-contents
|
||||
pasteboard-handle pasteboard-string ;
|
||||
handle>> pasteboard-string ;
|
||||
|
||||
M: pasteboard set-clipboard-contents
|
||||
pasteboard-handle set-pasteboard-string ;
|
||||
handle>> set-pasteboard-string ;
|
||||
|
||||
: init-clipboard ( -- )
|
||||
NSPasteboard -> generalPasteboard <pasteboard>
|
||||
|
@ -44,29 +44,29 @@ M: pasteboard set-clipboard-contents
|
|||
dup install-window-delegate
|
||||
over -> release
|
||||
<handle>
|
||||
] keep set-world-handle ;
|
||||
] keep (>>handle) ;
|
||||
|
||||
M: cocoa-ui-backend set-title ( string world -- )
|
||||
world-handle handle-window swap <NSString> -> setTitle: ;
|
||||
handle>> window>> swap <NSString> -> setTitle: ;
|
||||
|
||||
: enter-fullscreen ( world -- )
|
||||
world-handle handle-view
|
||||
handle>> view>>
|
||||
NSScreen -> mainScreen
|
||||
f -> enterFullScreenMode:withOptions:
|
||||
drop ;
|
||||
|
||||
: exit-fullscreen ( world -- )
|
||||
world-handle handle-view f -> exitFullScreenModeWithOptions: ;
|
||||
handle>> view>> f -> exitFullScreenModeWithOptions: ;
|
||||
|
||||
M: cocoa-ui-backend set-fullscreen* ( ? world -- )
|
||||
swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
|
||||
|
||||
M: cocoa-ui-backend fullscreen* ( world -- ? )
|
||||
world-handle handle-view -> isInFullScreenMode zero? not ;
|
||||
handle>> view>> -> isInFullScreenMode zero? not ;
|
||||
|
||||
: auto-position ( world -- )
|
||||
dup window-loc>> { 0 0 } = [
|
||||
world-handle handle-window -> center
|
||||
handle>> window>> -> center
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
@ -74,29 +74,29 @@ M: cocoa-ui-backend fullscreen* ( world -- ? )
|
|||
M: cocoa-ui-backend (open-window) ( world -- )
|
||||
dup gadget-window
|
||||
dup auto-position
|
||||
world-handle handle-window f -> makeKeyAndOrderFront: ;
|
||||
handle>> window>> f -> makeKeyAndOrderFront: ;
|
||||
|
||||
M: cocoa-ui-backend (close-window) ( handle -- )
|
||||
handle-window -> release ;
|
||||
window>> -> release ;
|
||||
|
||||
M: cocoa-ui-backend close-window ( gadget -- )
|
||||
find-world [
|
||||
world-handle [
|
||||
handle-window f -> performClose:
|
||||
handle>> [
|
||||
window>> f -> performClose:
|
||||
] when*
|
||||
] when* ;
|
||||
|
||||
M: cocoa-ui-backend raise-window* ( world -- )
|
||||
world-handle [
|
||||
handle-window dup f -> orderFront: -> makeKeyWindow
|
||||
handle>> [
|
||||
window>> dup f -> orderFront: -> makeKeyWindow
|
||||
NSApp 1 -> activateIgnoringOtherApps:
|
||||
] when* ;
|
||||
|
||||
M: cocoa-ui-backend select-gl-context ( handle -- )
|
||||
handle-view -> openGLContext -> makeCurrentContext ;
|
||||
view>> -> openGLContext -> makeCurrentContext ;
|
||||
|
||||
M: cocoa-ui-backend flush-gl-context ( handle -- )
|
||||
handle-view -> openGLContext -> flushBuffer ;
|
||||
view>> -> openGLContext -> flushBuffer ;
|
||||
|
||||
M: cocoa-ui-backend beep ( -- )
|
||||
NSBeep ;
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types kernel math windows windows.kernel32
|
||||
namespaces calendar calendar.backend ;
|
||||
namespaces calendar ;
|
||||
IN: windows.time
|
||||
|
||||
: >64bit ( lo hi -- n )
|
||||
|
|
|
@ -53,7 +53,7 @@ M: mismatched summary ( obj -- str )
|
|||
TUPLE: unclosed < parsing-error tags ;
|
||||
: <unclosed> ( -- unclosed )
|
||||
unclosed parsing-error
|
||||
xml-stack get rest-slice [ first opener-name ] map >>tags ;
|
||||
xml-stack get rest-slice [ first name>> ] map >>tags ;
|
||||
M: unclosed summary ( obj -- str )
|
||||
[
|
||||
dup call-next-method write
|
||||
|
|
|
@ -49,7 +49,7 @@ SYMBOL: ns-stack
|
|||
! Parsing names
|
||||
|
||||
: version=1.0? ( -- ? )
|
||||
prolog-data get prolog-version "1.0" = ;
|
||||
prolog-data get version>> "1.0" = ;
|
||||
|
||||
! version=1.0? is calculated once and passed around for efficiency
|
||||
|
||||
|
@ -69,7 +69,7 @@ SYMBOL: ns-stack
|
|||
|
||||
: (parse-entity) ( string -- )
|
||||
dup entities at [ , ] [
|
||||
prolog-data get prolog-standalone
|
||||
prolog-data get standalone>>
|
||||
[ <no-entity> throw ] [
|
||||
dup extra-entities get at
|
||||
[ , ] [ <no-entity> throw ] ?if
|
||||
|
|
|
@ -18,15 +18,15 @@ C: <q/a> q/a
|
|||
: li>q/a ( li -- q/a )
|
||||
[ "br" tag-named*? not ] filter
|
||||
[ "strong" tag-named*? ] find-after
|
||||
>r tag-children r> <q/a> ;
|
||||
>r children>> r> <q/a> ;
|
||||
|
||||
: q/a>li ( q/a -- li )
|
||||
[ question>> "strong" build-tag* f "br" build-tag* 2array ] keep
|
||||
answer>> append "li" build-tag* ;
|
||||
|
||||
: xml>q/a ( xml -- q/a )
|
||||
[ "question" tag-named tag-children ] keep
|
||||
"answer" tag-named tag-children <q/a> ;
|
||||
[ "question" tag-named children>> ] keep
|
||||
"answer" tag-named children>> <q/a> ;
|
||||
|
||||
: q/a>xml ( q/a -- xml )
|
||||
[ question>> "question" build-tag* ] keep
|
||||
|
@ -39,7 +39,7 @@ C: <question-list> question-list
|
|||
|
||||
: xml>question-list ( list -- question-list )
|
||||
[ "title" swap at ] keep
|
||||
tag-children [ tag? ] filter [ xml>q/a ] map
|
||||
children>> [ tag? ] filter [ xml>q/a ] map
|
||||
<question-list> ;
|
||||
|
||||
: question-list>xml ( question-list -- list )
|
||||
|
|
|
@ -176,7 +176,7 @@ CHLOE: a
|
|||
[ link-attrs ]
|
||||
[ "method" optional-attr "post" or =method ]
|
||||
[ "action" required-attr resolve-base-path =action ]
|
||||
[ tag-attrs non-chloe-attrs-only print-attrs ]
|
||||
[ attrs>> non-chloe-attrs-only print-attrs ]
|
||||
} cleave
|
||||
form>
|
||||
]
|
||||
|
@ -196,13 +196,13 @@ STRING: button-tag-markup
|
|||
;
|
||||
|
||||
: add-tag-attrs ( attrs tag -- )
|
||||
tag-attrs swap update ;
|
||||
attrs>> swap update ;
|
||||
|
||||
CHLOE: button
|
||||
button-tag-markup string>xml delegate
|
||||
{
|
||||
[ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ]
|
||||
[ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
|
||||
[ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
|
||||
[ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
|
||||
[ [ children>string 1array ] dip "button" tag-named set-tag-children ]
|
||||
[ nip ]
|
||||
} 2cleave process-chloe-tag ;
|
||||
|
|
|
@ -22,10 +22,10 @@ C: <chloe> chloe
|
|||
DEFER: process-template
|
||||
|
||||
: chloe-attrs-only ( assoc -- assoc' )
|
||||
[ drop name-url chloe-ns = ] assoc-filter ;
|
||||
[ drop url>> chloe-ns = ] assoc-filter ;
|
||||
|
||||
: non-chloe-attrs-only ( assoc -- assoc' )
|
||||
[ drop name-url chloe-ns = not ] assoc-filter ;
|
||||
[ drop url>> chloe-ns = not ] assoc-filter ;
|
||||
|
||||
: chloe-tag? ( tag -- ? )
|
||||
dup xml? [ body>> ] when
|
||||
|
@ -148,10 +148,10 @@ CHLOE-TUPLE: code
|
|||
process-template
|
||||
] [
|
||||
{
|
||||
[ xml-prolog write-prolog ]
|
||||
[ xml-before write-chunk ]
|
||||
[ prolog>> write-prolog ]
|
||||
[ before>> write-chunk ]
|
||||
[ process-template ]
|
||||
[ xml-after write-chunk ]
|
||||
[ after>> write-chunk ]
|
||||
} cleave
|
||||
] if
|
||||
] with-scope ;
|
||||
|
|
|
@ -10,7 +10,7 @@ IN: springies.ui
|
|||
: draw-node ( node -- ) pos>> { -5 -5 } v+ dup { 10 10 } v+ gl-rect ;
|
||||
|
||||
: draw-spring ( spring -- )
|
||||
[ spring-node-a pos>> ] [ spring-node-b pos>> ] bi gl-line ;
|
||||
[ node-a>> pos>> ] [ node-b>> pos>> ] bi gl-line ;
|
||||
|
||||
: draw-nodes ( -- ) nodes> [ draw-node ] each ;
|
||||
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
|
||||
USING: kernel namespaces namespaces.lib math sequences vars mortar slot-accessors x ;
|
||||
USING: kernel namespaces namespaces.lib math sequences vars mortar
|
||||
accessors slot-accessors x ;
|
||||
|
||||
IN: x.widgets.wm.workspace
|
||||
|
||||
|
@ -23,9 +24,9 @@ dpy get $default-root <- children [ <- mapped? ] filter ;
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: switch-to-workspace ( n -- )
|
||||
mapped-windows current-workspace> workspaces> nth set-workspace-windows
|
||||
mapped-windows current-workspace> workspaces> nth (>>windows)
|
||||
mapped-windows [ <- unmap drop ] each
|
||||
dup workspaces> nth workspace-windows [ <- map drop ] each
|
||||
dup workspaces> nth windows>> [ <- map drop ] each
|
||||
current-workspace set* ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
Loading…
Reference in New Issue