Merge branch 'master' of git://factorcode.org/git/factor
U-FROGGER\erg
commit
0a1c81fa8b
|
|
@ -71,7 +71,7 @@ ERROR: bad-alarm-frequency frequency ;
|
|||
] when* ;
|
||||
|
||||
: init-alarms ( -- )
|
||||
alarms global [ cancel-alarms <min-heap> ] change-at
|
||||
alarms [ cancel-alarms <min-heap> ] change-global
|
||||
[ alarm-thread-loop t ] "Alarms" spawn-server
|
||||
alarm-thread set-global ;
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ compiler.units lexer init ;
|
|||
IN: cocoa
|
||||
|
||||
: (remember-send) ( selector variable -- )
|
||||
global [ dupd ?set-at ] change-at ;
|
||||
[ dupd ?set-at ] change-global ;
|
||||
|
||||
SYMBOL: sent-messages
|
||||
|
||||
|
|
|
|||
|
|
@ -151,8 +151,8 @@ SYMBOL: event-stream-callbacks
|
|||
\ event-stream-counter counter ;
|
||||
|
||||
[
|
||||
event-stream-callbacks global
|
||||
[ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-at
|
||||
event-stream-callbacks
|
||||
[ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-global
|
||||
] "core-foundation" add-init-hook
|
||||
|
||||
: add-event-source-callback ( quot -- id )
|
||||
|
|
|
|||
|
|
@ -46,14 +46,16 @@ mouse-index
|
|||
{ takes-focus? initial: t }
|
||||
focused? ;
|
||||
|
||||
: <table> ( rows renderer -- table )
|
||||
table new-line-gadget
|
||||
: new-table ( rows renderer class -- table )
|
||||
new-line-gadget
|
||||
swap >>renderer
|
||||
swap >>model
|
||||
f <model> >>selected-value
|
||||
sans-serif-font >>font
|
||||
focus-border-color >>focus-border-color
|
||||
transparent >>column-line-color ;
|
||||
transparent >>column-line-color ; inline
|
||||
|
||||
: <table> ( rows renderer -- table ) table new-table ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: ui.tools.common
|
|||
|
||||
SYMBOL: tool-dims
|
||||
|
||||
tool-dims global [ H{ } clone or ] change-at
|
||||
tool-dims [ H{ } clone ] initialize
|
||||
|
||||
TUPLE: tool < track ;
|
||||
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ SYMBOL: windows
|
|||
[ [ length 1- dup 1- ] keep exchange ] [ drop ] if ;
|
||||
|
||||
: unregister-window ( handle -- )
|
||||
windows global [ [ first = not ] with filter ] change-at ;
|
||||
windows [ [ first = not ] with filter ] change-global ;
|
||||
|
||||
: raised-window ( world -- )
|
||||
windows get-global
|
||||
|
|
|
|||
|
|
@ -842,7 +842,7 @@ SYMBOLS:
|
|||
[ define-constants ] "windows.dinput.constants" add-init-hook
|
||||
|
||||
: uninitialize ( variable quot -- )
|
||||
[ global ] dip '[ _ when* f ] change-at ; inline
|
||||
'[ _ when* f ] change-global ; inline
|
||||
|
||||
: free-dinput-constants ( -- )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -14,7 +14,8 @@ ARTICLE: "namespaces-change" "Changing variable values"
|
|||
{ $subsection off }
|
||||
{ $subsection inc }
|
||||
{ $subsection dec }
|
||||
{ $subsection change } ;
|
||||
{ $subsection change }
|
||||
{ $subsection change-global } ;
|
||||
|
||||
ARTICLE: "namespaces-global" "Global variables"
|
||||
{ $subsection namespace }
|
||||
|
|
@ -73,6 +74,11 @@ HELP: change
|
|||
{ $description "Applies the quotation to the old value of the variable, and assigns the resulting value to the variable." }
|
||||
{ $side-effects "variable" } ;
|
||||
|
||||
HELP: change-global
|
||||
{ $values { "variable" "a variable, by convention a symbol" } { "quot" { $quotation "( old -- new )" } } }
|
||||
{ $description "Applies the quotation to the old value of the global variable, and assigns the resulting value to the global variable." }
|
||||
{ $side-effects "variable" } ;
|
||||
|
||||
HELP: +@
|
||||
{ $values { "n" "a number" } { "variable" "a variable, by convention a symbol" } }
|
||||
{ $description "Adds " { $snippet "n" } " to the value of the variable. A variable value of " { $link f } " is interpreted as being zero." }
|
||||
|
|
|
|||
|
|
@ -24,12 +24,13 @@ PRIVATE>
|
|||
: get-global ( variable -- value ) global at ;
|
||||
: set-global ( value variable -- ) global set-at ;
|
||||
: change ( variable quot -- ) [ [ get ] keep ] dip dip set ; inline
|
||||
: change-global ( variable quot -- ) [ global ] dip change-at ; inline
|
||||
: +@ ( n variable -- ) [ 0 or + ] change ;
|
||||
: inc ( variable -- ) 1 swap +@ ; inline
|
||||
: dec ( variable -- ) -1 swap +@ ; inline
|
||||
: bind ( ns quot -- ) swap >n call ndrop ; inline
|
||||
: counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ;
|
||||
: counter ( variable -- n ) [ 0 or 1+ dup ] change-global ;
|
||||
: make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline
|
||||
: with-scope ( quot -- ) 5 <hashtable> swap bind ; inline
|
||||
: with-variable ( value key quot -- ) [ associate ] dip bind ; inline
|
||||
: initialize ( variable quot -- ) [ global ] dip [ unless* ] curry change-at ; inline
|
||||
: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
USING: tools.deploy.config ;
|
||||
H{
|
||||
{ deploy-unicode? f }
|
||||
{ deploy-threads? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-name "drills" }
|
||||
{ deploy-ui? t }
|
||||
{ deploy-compiler? t }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
{ deploy-io 2 }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-reflection 1 }
|
||||
}
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
USING: accessors arrays cocoa.dialogs combinators continuations
|
||||
fry grouping io.encodings.utf8 io.files io.styles kernel math
|
||||
math.parser models models.arrow models.history namespaces random
|
||||
sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
|
||||
ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
|
||||
ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
|
||||
wrap.strings system ;
|
||||
|
||||
IN: drills.deployed
|
||||
SYMBOLS: it startLength ;
|
||||
: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
|
||||
: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
|
||||
: op ( quot str -- gadget ) <label> big swap <book-bevel-btn> ;
|
||||
|
||||
: show ( model -- gadget ) dup it set-global [ random ] <arrow>
|
||||
{ [ [ first ] card ]
|
||||
[ [ second ] card ]
|
||||
[ '[ |<< it get _ model-changed ] "No" op ]
|
||||
[ '[ |<< [ it get [
|
||||
_ value>> swap remove
|
||||
[ [ it get go-back ] "Drill Complete" alert return ] when-empty
|
||||
] change-model ] with-return ] "Yes" op ]
|
||||
} cleave
|
||||
2array { 1 0 } <track> swap [ 0.5 track-add ] each
|
||||
3array <book*> 3 3 <frame> { 1 1 } >>filled-cell { 450 175 } >>pref-dim swap { 1 1 } grid-add
|
||||
it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> { 1 2 } grid-add ;
|
||||
|
||||
: drill ( -- ) [
|
||||
open-panel [
|
||||
[ utf8 file-lines [ "\t" split [ 25 wrap-string ] map ] map dup [ first2 swap 2array ] map append ] map concat
|
||||
[ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
|
||||
"Got it?" open-window
|
||||
] [ 0 exit ] if*
|
||||
] with-ui ;
|
||||
|
||||
MAIN: drill
|
||||
|
|
@ -3,40 +3,34 @@ fry grouping io.encodings.utf8 io.files io.styles kernel math
|
|||
math.parser models models.arrow models.history namespaces random
|
||||
sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
|
||||
ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
|
||||
ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks ui.gestures
|
||||
ui.gadgets.corners ;
|
||||
ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
|
||||
wrap.strings ;
|
||||
|
||||
IN: drills
|
||||
SYMBOLS: it startLength ;
|
||||
: big ( gadget -- gadget ) { "sans-serif" plain 30 } >>font ;
|
||||
: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
|
||||
: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
|
||||
: op ( quot str -- gadget ) <label> big swap <book-bevel-btn> ;
|
||||
|
||||
: show ( model -- gadget ) dup it set-global [ random ] <arrow>
|
||||
{ [ [ first ] card ]
|
||||
[ [ [ second ] [ drop [ "malformed input" throw ] "Malformed Input" alert ] recover ] card ]
|
||||
[ '[ |<< [ it get [
|
||||
_ value>> swap remove
|
||||
[ [ it get go-back ] "Drill Complete" alert return ] when-empty
|
||||
] change-model ] with-return ] "Yes" op ]
|
||||
[ '[ |<< it get _ model-changed ] "No" op ] } cleave
|
||||
[ [ second ] card ]
|
||||
[ '[ |<< it get _ model-changed ] "No" op ]
|
||||
[ '[ |<< [ it get [
|
||||
_ value>> swap remove
|
||||
[ [ it get go-back ] "Drill Complete" alert return ] when-empty
|
||||
] change-model ] with-return ] "Yes" op ]
|
||||
} cleave
|
||||
2array { 1 0 } <track> swap [ 0.5 track-add ] each
|
||||
3array <book*> 3 3 <frame> { 450 175 } >>pref-dim swap @center grid-add
|
||||
it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> @bottom grid-add ;
|
||||
3array <book*> 3 3 <frame> { 1 1 } >>filled-cell { 450 175 } >>pref-dim swap { 1 1 } grid-add
|
||||
it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> { 1 2 } grid-add ;
|
||||
|
||||
: drill ( -- ) [
|
||||
: drill ( -- ) [
|
||||
open-panel [
|
||||
[ utf8 file-lines [ "\t" split
|
||||
[ " " split 4 group [ " " join ] map ] map ] map ] map concat dup [ [ first ] [ second ] bi swap 2array ] map append
|
||||
[ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
|
||||
"Got it?" open-window
|
||||
[ utf8 file-lines [ "\t" split [ 25 wrap-string ] map ] map dup [ first2 swap 2array ] map append ] map concat
|
||||
[ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
|
||||
"Got it?" open-window
|
||||
] when*
|
||||
] with-ui ;
|
||||
|
||||
|
||||
MAIN: drill
|
||||
|
||||
|
||||
! FIXME: command-line opening
|
||||
! TODO: Menu bar
|
||||
! TODO: Pious hot-buttons
|
||||
MAIN: drill
|
||||
|
|
@ -22,7 +22,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
|||
+dinput+ set-global ;
|
||||
|
||||
: delete-dinput ( -- )
|
||||
+dinput+ global [ com-release f ] change-at ;
|
||||
+dinput+ [ com-release f ] change-global ;
|
||||
|
||||
: device-for-guid ( guid -- device )
|
||||
+dinput+ get swap f <void*>
|
||||
|
|
@ -172,10 +172,8 @@ TUPLE: window-rect < rect window-loc ;
|
|||
[ +device-change-window+ set-global ] bi ;
|
||||
|
||||
: close-device-change-window ( -- )
|
||||
+device-change-handle+ global
|
||||
[ UnregisterDeviceNotification drop f ] change-at
|
||||
+device-change-window+ global
|
||||
[ DestroyWindow win32-error=0/f f ] change-at ;
|
||||
+device-change-handle+ [ UnregisterDeviceNotification drop f ] change-global
|
||||
+device-change-window+ [ DestroyWindow win32-error=0/f f ] change-global ;
|
||||
|
||||
: add-wm-devicechange ( -- )
|
||||
[ 4dup handle-wm-devicechange DefWindowProc ]
|
||||
|
|
@ -185,14 +183,11 @@ TUPLE: window-rect < rect window-loc ;
|
|||
WM_DEVICECHANGE wm-handlers get-global delete-at ;
|
||||
|
||||
: release-controllers ( -- )
|
||||
+controller-devices+ global [
|
||||
[ drop com-release ] assoc-each f
|
||||
] change-at
|
||||
+controller-devices+ [ [ drop com-release ] assoc-each f ] change-global
|
||||
f +controller-guids+ set-global ;
|
||||
|
||||
: release-keyboard ( -- )
|
||||
+keyboard-device+ global
|
||||
[ com-release f ] change-at
|
||||
+keyboard-device+ [ com-release f ] change-global
|
||||
f +keyboard-state+ set-global ;
|
||||
|
||||
M: dinput-game-input-backend (open-game-input)
|
||||
|
|
|
|||
|
|
@ -239,7 +239,7 @@ M: iokit-game-input-backend (reset-game-input)
|
|||
|
||||
M: iokit-game-input-backend (close-game-input)
|
||||
+hid-manager+ get-global [
|
||||
+hid-manager+ global [
|
||||
+hid-manager+ [
|
||||
[
|
||||
CFRunLoopGetMain CFRunLoopDefaultMode
|
||||
IOHIDManagerUnscheduleFromRunLoop
|
||||
|
|
@ -247,7 +247,7 @@ M: iokit-game-input-backend (close-game-input)
|
|||
[ 0 IOHIDManagerClose drop ]
|
||||
[ CFRelease ] tri
|
||||
f
|
||||
] change-at
|
||||
] change-global
|
||||
f +keyboard-state+ set-global
|
||||
f +controller-states+ set-global
|
||||
] when ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,15 @@
|
|||
USING: tools.deploy.config ;
|
||||
H{
|
||||
{ deploy-math? t }
|
||||
{ deploy-io 2 }
|
||||
{ deploy-unicode? t }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-ui? t }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-name "Merger" }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-threads? t }
|
||||
{ deploy-word-defs? f }
|
||||
}
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
USING: accessors arrays fry io.directories kernel models sequences sets ui
|
||||
ui.gadgets ui.gadgets.buttons ui.gadgets.labeled
|
||||
ui.gadgets.tracks ui.gadgets.labels ui.gadgets.glass
|
||||
math.rectangles cocoa.dialogs ;
|
||||
IN: merger
|
||||
: main ( -- ) [
|
||||
vertical <track>
|
||||
{ "From:" "To:" } f <model> f <model> 2array
|
||||
[
|
||||
[
|
||||
"…" [
|
||||
open-panel [ first
|
||||
[ <label> 1array >>children drop ]
|
||||
[ swap set-control-value ] 2bi ] [ drop ] if*
|
||||
] <border-button> swap >>model swap <labeled-gadget>
|
||||
1 track-add
|
||||
] 2each
|
||||
] keep
|
||||
dup first2
|
||||
'[ _ [ value>> ] all? [ parent>> "processing..." <label> [
|
||||
<zero-rect> show-glass
|
||||
_ value>> [
|
||||
"." _ value>> [ [ directory-files ] bi@ diff ] keep copy-files-into
|
||||
] with-directory
|
||||
] keep hide-glass
|
||||
] [ drop ] if ]
|
||||
"merge" swap <border-button> 0.4 track-add { 300 220 } >>pref-dim "Merging" open-window
|
||||
] with-ui ;
|
||||
|
||||
MAIN: main
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
unportable
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Sam Anklesaria
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: modules.rpc-server vocabs ;
|
||||
IN: modules.remote-loading mem-service
|
||||
|
||||
: get-vocab ( vocabstr -- vocab ) vocab ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
required for listeners allowing remote loading of modules
|
||||
|
|
@ -0,0 +1 @@
|
|||
Sam Anklesaria
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
USING: accessors assocs continuations effects io
|
||||
io.encodings.binary io.servers.connection kernel
|
||||
memoize namespaces parser sets sequences serialize
|
||||
threads vocabs vocabs.parser words ;
|
||||
|
||||
IN: modules.rpc-server
|
||||
|
||||
SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global
|
||||
|
||||
: do-rpc ( args word -- bytes )
|
||||
[ execute ] curry with-datastack object>bytes ; inline
|
||||
|
||||
MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline
|
||||
|
||||
: process ( vocabspec -- ) vocab-words [ deserialize ] dip deserialize
|
||||
swap at "executer" get execute( args word -- bytes ) write flush ;
|
||||
|
||||
: (serve) ( -- ) deserialize dup serving-vocabs get-global index
|
||||
[ process ] [ drop ] if ;
|
||||
|
||||
: start-serving-vocabs ( -- ) [
|
||||
<threaded-server> 5000 >>insecure binary >>encoding [ (serve) ] >>handler
|
||||
start-server ] in-thread ;
|
||||
|
||||
: (service) ( -- ) serving-vocabs get-global empty? [ start-serving-vocabs ] when
|
||||
current-vocab serving-vocabs get-global adjoin
|
||||
"get-words" create-in
|
||||
in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
|
||||
(( -- words )) define-inline ;
|
||||
|
||||
SYNTAX: service \ do-rpc "executer" set (service) ;
|
||||
SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ;
|
||||
|
||||
load-vocab-hook [
|
||||
[ dup words>> values
|
||||
\ mem-do-rpc "memoize" word-prop [ delete-at ] curry each ]
|
||||
append ] change-global
|
||||
|
|
@ -0,0 +1 @@
|
|||
remote procedure call server
|
||||
|
|
@ -0,0 +1 @@
|
|||
Sam Anklesaria
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
USING: help.syntax help.markup ;
|
||||
IN: modules.rpc
|
||||
ARTICLE: { "modules" "protocol" } "RPC Protocol"
|
||||
{ $list
|
||||
"Send vocab as string"
|
||||
"Send arglist"
|
||||
"Send word as string"
|
||||
"Receive result list"
|
||||
} ;
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
USING: accessors compiler.units combinators fry generalizations io
|
||||
io.encodings.binary io.sockets kernel namespaces
|
||||
parser sequences serialize vocabs vocabs.parser words ;
|
||||
IN: modules.rpc
|
||||
|
||||
DEFER: get-words
|
||||
|
||||
: remote-quot ( addrspec vocabspec effect str -- quot )
|
||||
'[ _ 5000 <inet> binary
|
||||
[
|
||||
_ serialize _ in>> length narray serialize _ serialize flush deserialize dup length firstn
|
||||
] with-client
|
||||
] ;
|
||||
|
||||
: define-remote ( addrspec vocabspec effect str -- ) [
|
||||
[ remote-quot ] 2keep create-in -rot define-declared word make-inline
|
||||
] with-compilation-unit ;
|
||||
|
||||
: with-in ( vocab quot -- vocab ) over
|
||||
[ '[ _ set-in @ ] in get swap dip set-in ] dip vocab ; inline
|
||||
|
||||
: remote-vocab ( addrspec vocabspec -- vocab )
|
||||
dup "-remote" append [
|
||||
[ (( -- words )) [ "get-words" remote-quot ] keep call-effect ] 2keep
|
||||
[ rot first2 swap define-remote ] 2curry each
|
||||
] with-in ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
remote procedure call client
|
||||
|
|
@ -0,0 +1 @@
|
|||
Sam Anklesaria
|
||||
|
|
@ -0,0 +1 @@
|
|||
module pushing in remote-loading listeners
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
USING: assocs modules.rpc-server vocabs
|
||||
modules.remote-loading words ;
|
||||
IN: modules.uploads service
|
||||
|
||||
: upload-vocab ( word binary -- ) \ get-vocab "memoize" word-prop set-at ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Sam Anklesaria
|
||||
|
|
@ -0,0 +1 @@
|
|||
improved module import syntax
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
USING: modules.rpc-server io.servers.connection ;
|
||||
IN: modules.test-server service
|
||||
: rpc-hello ( -- str ) "hello world" stop-this-server ;
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: modules.using ;
|
||||
IN: modules.using.tests
|
||||
USING: tools.test localhost::modules.test-server ;
|
||||
[ "hello world" ] [ rpc-hello ] unit-test
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
USING: modules.using modules.rpc-server help.syntax help.markup strings ;
|
||||
IN: modules
|
||||
|
||||
HELP: service
|
||||
{ $syntax "IN: module service" }
|
||||
{ $description "Starts a server for requests for remote procedure calls." } ;
|
||||
|
||||
ARTICLE: { "modules" "remote-loading" } "Using the remote-loading vocabulary"
|
||||
"If loaded, starts serving vocabularies, accessable through a " { $link POSTPONE: USING: } " form" ;
|
||||
|
||||
HELP: USING:
|
||||
{ $syntax "USING: rpc-server::module fetch-sever::module { module qualified-name } { module => word ... } ... ;" }
|
||||
{ $description "Adds vocabularies to the front of the search path. Vocabularies can be fetched remotely, if preceded by a valid hostname. Name pairs facilitate imports like in the "
|
||||
{ $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: FROM: } " forms." } ;
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
USING: assocs kernel modules.remote-loading modules.rpc
|
||||
namespaces peg peg.ebnf peg-lexer sequences vocabs vocabs.parser
|
||||
strings ;
|
||||
IN: modules.using
|
||||
|
||||
: >qualified ( vocab prefix -- assoc )
|
||||
[ vocab-words ] [ 58 suffix ] bi* [ swap [ prepend ] dip ] curry assoc-map ;
|
||||
|
||||
: >partial-vocab ( words assoc -- assoc )
|
||||
[ dupd at [ no-word-error ] unless* ] curry { } map>assoc ;
|
||||
|
||||
: remote-load ( addr vocabspec -- voab ) [ "modules.remote-loading" remote-vocab (use+) ] dip get-vocab ;
|
||||
|
||||
: load'em ( vocab words/? -- ) [ swap >partial-vocab ] when* use get push ;
|
||||
|
||||
EBNF: modulize
|
||||
tokenpart = (!(':').)+ => [[ >string ]]
|
||||
s = ':' => [[ drop ignore ]]
|
||||
rpc = tokenpart s s tokenpart => [[ first2 remote-vocab ]]
|
||||
remote = tokenpart s tokenpart => [[ first2 remote-load ]]
|
||||
plain = tokenpart => [[ load-vocab ]]
|
||||
module = rpc | remote | plain
|
||||
;EBNF
|
||||
|
||||
ON-BNF: USING:
|
||||
tokenizer = <foreign factor>
|
||||
sym = !(";"|"}"|"=>").
|
||||
modspec = sym => [[ modulize ]]
|
||||
qualified = modspec sym => [[ first2 >qualified ]]
|
||||
unqualified = modspec => [[ vocab-words ]]
|
||||
words = ("=>" sym+ )? => [[ [ f ] [ second ] if-empty ]]
|
||||
long = "{" ( qualified | unqualified ) words "}" => [[ rest first2 load'em ignore ]]
|
||||
short = modspec => [[ use+ ignore ]]
|
||||
wordSpec = long | short
|
||||
using = wordSpec+ ";" => [[ drop ignore ]]
|
||||
;ON-BNF
|
||||
|
|
@ -1,5 +1,6 @@
|
|||
USING: hashtables assocs sequences locals math accessors multiline delegate strings
|
||||
delegate.protocols kernel peg peg.ebnf lexer namespaces combinators parser words ;
|
||||
delegate.protocols kernel peg peg.ebnf peg.private lexer namespaces combinators parser
|
||||
words ;
|
||||
IN: peg-lexer
|
||||
|
||||
TUPLE: lex-hash hash ;
|
||||
|
|
@ -43,12 +44,12 @@ M: lex-hash at*
|
|||
|
||||
: parse* ( parser -- ast )
|
||||
compile
|
||||
[ execute( -- result ) [ error-stack get first throw ] unless* ] with-global-lexer
|
||||
ast>> ;
|
||||
[ execute [ error-stack get first throw ] unless* ] with-global-lexer
|
||||
ast>> ; inline
|
||||
|
||||
: create-bnf ( name parser -- )
|
||||
reset-tokenizer [ lexer get skip-blank parse* parsed ] curry
|
||||
define-syntax ;
|
||||
reset-tokenizer [ lexer get skip-blank parse* dup ignore? [ drop ] [ parsed ] if ] curry
|
||||
define-syntax word make-inline ;
|
||||
|
||||
SYNTAX: ON-BNF:
|
||||
CREATE-WORD reset-tokenizer ";ON-BNF" parse-multiline-string parse-ebnf
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Sam Anklesaria
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: kernel sequences splitting strings.parser ;
|
||||
IN: str-fry
|
||||
: str-fry ( str -- quot ) "_" split unclip [ [ rot glue ] reduce ] 2curry ;
|
||||
SYNTAX: I" parse-string rest str-fry over push-all ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
String Frying
|
||||
|
|
@ -0,0 +1 @@
|
|||
Sam Anklesaria
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
USING: ui.frp help.syntax help.markup monads sequences ;
|
||||
IN: ui.frp
|
||||
|
||||
! Layout utilities
|
||||
|
||||
HELP: ,
|
||||
{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
|
||||
HELP: ->
|
||||
{ $description "Like " { $link , } "but passes its model on for further use." } ;
|
||||
HELP: <hbox>
|
||||
{ $syntax "[ gadget , gadget , ... ] <hbox>" }
|
||||
{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
|
||||
HELP: <vbox>
|
||||
{ $syntax "[ gadget , gadget , ... ] <hbox>" }
|
||||
{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
|
||||
|
||||
! Gadgets
|
||||
HELP: <frp-button>
|
||||
{ $description "Creates an button whose model updates on clicks" } ;
|
||||
|
||||
HELP: <merge>
|
||||
{ $description "Creates a model that merges the updates of two others" } ;
|
||||
|
||||
HELP: <filter>
|
||||
{ $description "Creates a model that uses the updates of another model when they satisfy a given predicate" } ;
|
||||
|
||||
HELP: <fold>
|
||||
{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
|
||||
|
||||
HELP: switch
|
||||
{ $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ;
|
||||
|
||||
ARTICLE: { "frp" "instances" } "FRP Instances"
|
||||
"Models are all functors, as " { $link fmap } " corresponds directly to the " { $link "models.arrow" } " vocabulary. "
|
||||
"Also, a gadget is a monad. Binding recieves a model and creates a new gadget." ;
|
||||
|
||||
|
|
@ -0,0 +1,89 @@
|
|||
USING: accessors arrays colors fonts fry kernel models
|
||||
models.product monads sequences ui.gadgets ui.gadgets.buttons
|
||||
ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables
|
||||
ui.gadgets.tracks ui.render ;
|
||||
QUALIFIED: make
|
||||
IN: ui.frp
|
||||
|
||||
! Gadgets
|
||||
: <frp-button> ( text -- button ) [ t swap set-control-value ] <border-button> f <model> >>model ;
|
||||
TUPLE: frp-table < table quot val-quot color-quot column-titles column-alignment ;
|
||||
M: frp-table column-titles column-titles>> ;
|
||||
M: frp-table column-alignment column-alignment>> ;
|
||||
M: frp-table row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
|
||||
M: frp-table row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ;
|
||||
M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
|
||||
|
||||
: <frp-table> ( model quot -- table )
|
||||
frp-table new-line-gadget dup >>renderer swap >>quot swap >>model
|
||||
f <model> >>selected-value sans-serif-font >>font
|
||||
focus-border-color >>focus-border-color
|
||||
transparent >>column-line-color ;
|
||||
: <frp-field> ( -- field ) f <model> <model-field> ;
|
||||
|
||||
! Layout utilities
|
||||
|
||||
GENERIC: output-model ( gadget -- model )
|
||||
M: gadget output-model model>> ;
|
||||
M: frp-table output-model selected-value>> ;
|
||||
|
||||
GENERIC: , ( object -- )
|
||||
M: gadget , make:, ;
|
||||
M: model , activate-model ;
|
||||
|
||||
GENERIC: -> ( object -- model )
|
||||
M: gadget -> dup make:, output-model ;
|
||||
M: model -> dup , ;
|
||||
M: table -> dup , selected-value>> ;
|
||||
|
||||
: <box> ( gadgets type -- track )
|
||||
[ { } make:make ] dip <track> swap [ f track-add ] each ; inline
|
||||
: <box*> ( gadgets type -- track ) [ <box> ] [ [ model>> ] map <product> ] bi >>model ; inline
|
||||
: <hbox> ( gadgets -- track ) horizontal <box> ; inline
|
||||
: <vbox> ( gadgets -- track ) vertical <box> ; inline
|
||||
|
||||
! Model utilities
|
||||
TUPLE: multi-model < model ;
|
||||
! M: multi-model model-activated dup model-changed ;
|
||||
: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
|
||||
|
||||
TUPLE: merge-model < multi-model ;
|
||||
M: merge-model model-changed [ value>> ] dip set-model ;
|
||||
: <merge> ( models -- model ) merge-model <multi-model> ;
|
||||
|
||||
TUPLE: filter-model < multi-model quot ;
|
||||
M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2keep
|
||||
[ set-model ] [ 2drop ] if ;
|
||||
: <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-model> ] dip >>quot ;
|
||||
|
||||
TUPLE: fold-model < multi-model oldval quot ;
|
||||
M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi*
|
||||
call( val oldval -- newval ) ] keep set-model ;
|
||||
: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot swap >>oldval ;
|
||||
|
||||
TUPLE: switch-model < multi-model switcher on ;
|
||||
M: switch-model model-changed tuck [ switcher>> = ] 2keep
|
||||
'[ on>> [ _ value>> _ set-model ] when ] [ t swap (>>on) ] if ;
|
||||
: switch ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] keep >>switcher ;
|
||||
|
||||
TUPLE: mapped < model model quot ;
|
||||
|
||||
: <mapped> ( model quot -- arrow )
|
||||
f mapped new-model
|
||||
swap >>quot
|
||||
over >>model
|
||||
[ add-dependency ] keep ;
|
||||
|
||||
M: mapped model-changed
|
||||
[ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
|
||||
set-model ;
|
||||
|
||||
! Instances
|
||||
M: model fmap <mapped> ;
|
||||
|
||||
SINGLETON: gadget-monad
|
||||
INSTANCE: gadget-monad monad
|
||||
INSTANCE: gadget monad
|
||||
M: gadget monad-of drop gadget-monad ;
|
||||
M: gadget-monad return drop <gadget> swap >>model ;
|
||||
M: gadget >>= model>> '[ _ swap call( x -- y ) ] ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Utilities for functional reactive programming in user interfaces
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: accessors ui ui.gadgets ui.gadgets.labels ui.gadgets.buttons ui.gadgets.packs locals sequences io.styles ;
|
||||
USING: accessors ui ui.gadgets ui.gadgets.labels ui.gadgets.buttons ui.gadgets.packs locals sequences fonts io.styles ;
|
||||
IN: ui.gadgets.alerts
|
||||
:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align string <label> { "sans-serif" plain 18 } >>font { 200 100 } >>pref-dim add-gadget
|
||||
:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align string <label> T{ font { name "sans-serif" } { size 18 } } >>font { 200 100 } >>pref-dim add-gadget
|
||||
"okay" [ close-window ] quot append <border-button> add-gadget "" open-window ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Sam Anklesaria
|
||||
|
|
@ -0,0 +1 @@
|
|||
Really simple dialog boxes
|
||||
|
|
@ -0,0 +1 @@
|
|||
Sam Anklesaria
|
||||
|
|
@ -0,0 +1 @@
|
|||
Easily switch between pages of book views
|
||||
|
|
@ -0,0 +1 @@
|
|||
Sam Anklesaria
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
USING: accessors arrays kernel math.rectangles models sequences
|
||||
ui.frp ui.gadgets ui.gadgets.glass ui.gadgets.labels
|
||||
ui.gadgets.tables ui.gestures ;
|
||||
IN: ui.gadgets.comboboxes
|
||||
|
||||
TUPLE: combo-table < table spawner ;
|
||||
|
||||
M: combo-table handle-gesture [ call-next-method ] 2keep swap
|
||||
T{ button-up } = [
|
||||
[ spawner>> ]
|
||||
[ selected-value>> value>> [ swap set-control-value ] [ drop ] if* ]
|
||||
[ hide-glass ] tri drop t
|
||||
] [ drop ] if ;
|
||||
|
||||
TUPLE: combobox < label-control table ;
|
||||
combobox H{
|
||||
{ T{ button-down } [ dup table>> over >>spawner <zero-rect> show-glass ] }
|
||||
} set-gestures
|
||||
|
||||
: <combobox> ( options -- combobox ) [ first [ combobox new-label ] keep <model> >>model ] keep
|
||||
[ 1array ] map <model> trivial-renderer combo-table new-table
|
||||
>>table ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Combo boxes have a model choosen from a list of options
|
||||
|
|
@ -56,9 +56,6 @@ SYMBOL: *calling*
|
|||
: subtract-overhead ( {oldtime,n} overhead -- {newtime,n} )
|
||||
[ first2 ] dip
|
||||
swap [ * - ] keep 2array ;
|
||||
|
||||
: change-global ( variable quot -- )
|
||||
global swap change-at ; inline
|
||||
|
||||
: (correct-for-timing-overhead) ( timingshash -- timingshash )
|
||||
time-dummy-word [ subtract-overhead ] curry assoc-map ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue