diff --git a/basis/disjoint-sets/disjoint-sets-docs.factor b/basis/disjoint-sets/disjoint-sets-docs.factor new file mode 100644 index 0000000000..b1d7cf685a --- /dev/null +++ b/basis/disjoint-sets/disjoint-sets-docs.factor @@ -0,0 +1,58 @@ +IN: disjoint-sets +USING: help.markup help.syntax kernel assocs math ; + +HELP: +{ $values { "disjoint-set" disjoint-set } } +{ $description "Creates a new disjoint set data structure with no elements." } ; + +HELP: add-atom +{ $values { "a" object } { "disjoint-set" disjoint-set } } +{ $description "Adds a new element to the disjoint set, initially only equivalent to itself." } ; + +HELP: equiv-set-size +{ $values { "a" object } { "disjoint-set" disjoint-set } { "n" integer } } +{ $description "Outputs the number of elements in the equivalence class of " { $snippet "a" } "." } ; + +HELP: equiv? +{ $values { "a" object } { "b" object } { "disjoint-set" disjoint-set } { "?" "a boolean" } } +{ $description "Tests if two elements belong to the same equivalence class." } ; + +HELP: equate +{ $values { "a" object } { "b" object } { "disjoint-set" disjoint-set } } +{ $description "Merges the equivalence classes of two elements, which must previously have been added with " { $link add-atom } "." } ; + +HELP: assoc>disjoint-set +{ $values { "assoc" assoc } { "disjoint-set" disjoint-set } } +{ $description "Given an assoc representation of a graph where the keys are vertices and key/value pairs are edges, creates a disjoint set whose elements are the keys of assoc, and two keys are equvalent if they belong to the same connected component of the graph." } +{ $examples + { $example + "USING: disjoint-sets kernel prettyprint ;" + "H{ { 1 1 } { 2 1 } { 3 4 } { 4 4 } { 5 3 } } assoc>disjoint-set" + "1 2 pick equiv? ." + "4 5 pick equiv? ." + "1 5 pick equiv? ." + "drop" + "t\nt\nf\n" + } +} ; + +ARTICLE: "disjoint-sets" "Disjoint sets" +"The " { $emphasis "disjoint set" } " data structure, also known as " { $emphasis "union-find" } " (after the two main operations which it supports) represents a set of elements partitioned into disjoint equivalence classes, or alternatively, an equivalence relation on a set." +$nl +"The two main supported operations are equating two elements, which joins their equivalence classes, and checking if two elements belong to the same equivalence class. Both operations have the time complexity of the inverse Ackermann function, which for all intents and purposes is constant time." +$nl +"The class of disjoint sets:" +{ $subsection disjoint-set } +"Creating new disjoint sets:" +{ $subsection } +{ $subsection assoc>disjoint-set } +"Queries:" +{ $subsection equiv? } +{ $subsection equiv-set-size } +"Adding elements:" +{ $subsection add-atom } +"Equating elements:" +{ $subsection equate } +"Additionally, disjoint sets implement the " { $link clone } " generic word." ; + +ABOUT: "disjoint-sets" diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor index 284d206da4..a885e333c5 100644 --- a/basis/disjoint-sets/disjoint-sets.factor +++ b/basis/disjoint-sets/disjoint-sets.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Eric Mertens. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays hints kernel locals math hashtables -assocs ; +assocs fry ; IN: disjoint-sets @@ -36,8 +36,6 @@ TUPLE: disjoint-set : representative? ( a disjoint-set -- ? ) dupd parent = ; inline -PRIVATE> - GENERIC: representative ( a disjoint-set -- p ) M: disjoint-set representative @@ -45,8 +43,6 @@ M: disjoint-set representative [ [ parent ] keep representative dup ] 2keep set-parent ] if ; -> ] [ ranks>> ] [ counts>> ] tri [ clone ] tri@ disjoint-set boa ; + +: assoc>disjoint-set ( assoc -- disjoint-set ) + + [ '[ drop , add-atom ] assoc-each ] + [ '[ , equate ] assoc-each ] + [ nip ] + 2tri ; diff --git a/basis/windows/com/com-tests.factor b/basis/windows/com/com-tests.factor index cd67fd19d2..289581a929 100755 --- a/basis/windows/com/com-tests.factor +++ b/basis/windows/com/com-tests.factor @@ -45,7 +45,7 @@ C: test-implementation } } { "IUnrelated" { [ swap x>> + ] ! IUnrelated::xPlus - [ spin x>> * + ] ! IUnrealted::xMulAdd + [ spin x>> * + ] ! IUnrelated::xMulAdd } } } dup +test-wrapper+ set [ diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index 40c61dfbe7..782ebae516 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -1,11 +1,11 @@ -USING: alien alien.c-types windows.com.syntax +USING: alien alien.c-types windows.com.syntax init windows.com.syntax.private windows.com continuations kernel namespaces windows.ole32 libc vocabs assocs accessors arrays sequences quotations combinators math words compiler.units -destructors fry math.parser generalizations ; +destructors fry math.parser generalizations sets ; IN: windows.com.wrapper -TUPLE: com-wrapper vtbls disposed ; +TUPLE: com-wrapper callbacks vtbls disposed ; malloc ( byte-array -- alien ) [ byte-length malloc ] [ over byte-array>memory ] bi ; : (callback-word) ( function-name interface-name counter -- word ) @@ -99,7 +103,7 @@ unless [ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ] dip compose ; -: (make-vtbl) ( interface-name quots iunknown-methods n -- vtbl ) +: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words ) (thunk) (thunked-quots) swap [ find-com-interface-definition family-tree-functions ] keep (next-vtbl-counter) '[ @@ -114,12 +118,12 @@ unless first2 (finish-thunk) ] bi* "stdcall" swap compile-alien-callback - ] 2map >c-void*-array - (byte-array-to-malloced-buffer) ; + ] 2map ; -: (make-vtbls) ( implementations -- vtbls ) +: (make-callbacks) ( implementations -- sequence ) dup [ first ] map (make-iunknown-methods) - [ >r >r first2 r> r> swap (make-vtbl) ] curry map-index ; + [ >r >r first2 r> r> swap (make-interface-callbacks) ] + curry map-index ; : (malloc-wrapped-object) ( wrapper -- wrapped-object ) vtbls>> length "void*" heap-size * @@ -127,13 +131,34 @@ unless over 1 0 rot set-ulong-nth ; +: (callbacks>vtbl) ( callbacks -- vtbl ) + [ execute ] map >c-void*-array byte-array>malloc ; +: (callbacks>vtbls) ( callbacks -- vtbls ) + [ (callbacks>vtbl) ] map ; + +: (allocate-wrapper) ( wrapper -- ) + dup callbacks>> (callbacks>vtbls) >>vtbls + f >>disposed drop ; + +: (init-hook) ( -- ) + +live-wrappers+ get-global [ (allocate-wrapper) ] each + H{ } +wrapped-objects+ set-global ; + +[ (init-hook) ] "windows.com.wrapper" add-init-hook + PRIVATE> +: allocate-wrapper ( wrapper -- ) + [ (allocate-wrapper) ] + [ +live-wrappers+ get adjoin ] bi ; + : ( implementations -- wrapper ) - (make-vtbls) f com-wrapper boa ; + (make-callbacks) f f com-wrapper boa + dup allocate-wrapper ; M: com-wrapper dispose* - vtbls>> [ free ] each ; + [ [ free ] each f ] change-vtbls + +live-wrappers+ get-global delete ; : com-wrap ( object wrapper -- wrapped-object ) [ vtbls>> ] [ (malloc-wrapped-object) ] bi diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor index 8285cd776f..e481b47161 100644 --- a/extra/bunny/cel-shaded/cel-shaded.factor +++ b/extra/bunny/cel-shaded/cel-shaded.factor @@ -1,6 +1,6 @@ USING: arrays bunny.model continuations destructors kernel multiline opengl opengl.shaders opengl.capabilities opengl.gl -sequences sequences.lib accessors ; +sequences sequences.lib accessors combinators ; IN: bunny.cel-shaded STRING: vertex-shader-source @@ -78,13 +78,15 @@ TUPLE: bunny-cel-shaded program ; ] [ f ] if ; : (draw-cel-shaded-bunny) ( geom program -- ) - { - { "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] } - { "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] } - { "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] } - { "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] } - { "shininess" [ 100.0 glUniform1f ] } - } [ bunny-geom ] with-gl-program ; + [ + { + [ "light_direction" glGetUniformLocation 1.0 -1.0 1.0 glUniform3f ] + [ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ] + [ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ] + [ "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ] + [ "shininess" glGetUniformLocation 100.0 glUniform1f ] + } cleave bunny-geom + ] with-gl-program ; M: bunny-cel-shaded draw-bunny program>> (draw-cel-shaded-bunny) ; diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index fcba98a0e9..bf757c4fb3 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -220,13 +220,14 @@ TUPLE: bunny-outlined [ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ] [ depth-texture>> GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ] [ - pass2-program>> { - { "colormap" [ 0 glUniform1i ] } - { "normalmap" [ 1 glUniform1i ] } - { "depthmap" [ 2 glUniform1i ] } - { "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] } - } [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] - with-gl-program + pass2-program>> [ + { + [ "colormap" glGetUniformLocation 0 glUniform1i ] + [ "normalmap" glGetUniformLocation 1 glUniform1i ] + [ "depthmap" glGetUniformLocation 2 glUniform1i ] + [ "line_color" glGetUniformLocation 0.1 0.0 0.1 1.0 glUniform4f ] + } cleave { -1.0 -1.0 } { 1.0 1.0 } rect-vertices + ] with-gl-program ] } cleave ; diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor index d821b7c180..6cbbc51786 100644 --- a/extra/cfdg/cfdg.factor +++ b/extra/cfdg/cfdg.factor @@ -4,7 +4,8 @@ USING: kernel alien.c-types combinators namespaces arrays math math.functions math.vectors math.trig opengl.gl opengl.glu opengl ui ui.gadgets.slate vars colors self self.slots - random-weighted colors.hsv cfdg.gl accessors ; + random-weighted colors.hsv cfdg.gl accessors + ui.gadgets.handler ui.gestures assocs ui.gadgets ; IN: cfdg @@ -130,7 +131,7 @@ VAR: threshold ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: recursive ( quot -- ) iterate? swap when ; +: recursive ( quot -- ) iterate? swap when ; inline : multi ( seq -- ) random-weighted* call ; @@ -155,6 +156,28 @@ VAR: start-shape : set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: dlist + +! : build-model-dlist ( -- ) +! 1 glGenLists dlist set +! dlist get GL_COMPILE_AND_EXECUTE glNewList +! start-shape> call +! glEndList ; + +: build-model-dlist ( -- ) + 1 glGenLists dlist set + dlist get GL_COMPILE_AND_EXECUTE glNewList + + set-initial-color + + self> set-color + + start-shape> call + + glEndList ; + : display ( -- ) GL_PROJECTION glMatrixMode @@ -172,15 +195,43 @@ VAR: start-shape init-modelview-matrix-stack init-color-stack - set-initial-color + dlist get not + [ build-model-dlist ] + [ dlist get glCallList ] + if ; - self> set-color +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - start-shape> call ; +: delete-dlist ( -- ) dlist get [ dlist get 1 glDeleteLists dlist off ] when ; : cfdg-window* ( -- ) - [ display ] closed-quot - { 500 500 } over set-slate-pdim + C[ display ] + { 500 500 } >>pdim + C[ delete-dlist ] >>ungraft dup "CFDG" open-window ; -: cfdg-window ( -- ) [ cfdg-window* ] with-ui ; \ No newline at end of file +: cfdg-window ( -- ) [ cfdg-window* ] with-ui ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: the-slate + +: rebuild ( -- ) delete-dlist the-slate get relayout-1 ; + +: ( -- slate ) + C[ display ] + dup the-slate set + { 500 500 } >>pdim + C[ dlist get [ dlist get 1 glDeleteLists ] when ] >>ungraft + + H{ } clone + T{ key-down f f "ENTER" } C[ drop rebuild ] swap pick set-at + T{ button-down } C[ drop rebuild ] swap pick set-at + >>table ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USE: fry + +: cfdg-window. ( quot -- ) + '[ [ @ "CFDG" open-window ] with-scope ] with-ui ; \ No newline at end of file diff --git a/extra/cfdg/models/aqua-star/aqua-star.factor b/extra/cfdg/models/aqua-star/aqua-star.factor index f692328515..dbb7eb5ed0 100644 --- a/extra/cfdg/models/aqua-star/aqua-star.factor +++ b/extra/cfdg/models/aqua-star/aqua-star.factor @@ -25,11 +25,12 @@ iterate? [ ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run ( -- ) -[ -1 b ] >background -{ -60 140 -120 140 } viewport set -0.1 threshold set -[ anemone-begin ] start-shape set -cfdg-window ; +: init ( -- ) + [ -1 b ] >background + { -60 140 -120 140 } >viewport + 0.1 >threshold + [ anemone-begin ] >start-shape ; + +: run ( -- ) [ init ] cfdg-window. ; MAIN: run diff --git a/extra/cfdg/models/chiaroscuro/chiaroscuro.factor b/extra/cfdg/models/chiaroscuro/chiaroscuro.factor index 31f78c459e..1034f1527b 100644 --- a/extra/cfdg/models/chiaroscuro/chiaroscuro.factor +++ b/extra/cfdg/models/chiaroscuro/chiaroscuro.factor @@ -29,11 +29,12 @@ DEFER: white ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run ( -- ) -[ -0.5 b ] >background -{ -3 6 -2 6 } viewport set -0.01 threshold set -[ chiaroscuro ] start-shape set -cfdg-window ; +: init ( -- ) + [ -0.5 b ] >background + { -3 6 -2 6 } >viewport + 0.01 >threshold + [ chiaroscuro ] >start-shape ; + +: run ( -- ) [ init ] cfdg-window. ; MAIN: run diff --git a/extra/cfdg/models/flower6/flower6.factor b/extra/cfdg/models/flower6/flower6.factor index b77968c863..91fecd7fe5 100644 --- a/extra/cfdg/models/flower6/flower6.factor +++ b/extra/cfdg/models/flower6/flower6.factor @@ -18,12 +18,13 @@ iterate? [ ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run ( -- ) -[ ] >background -{ -1 2 -1 2 } viewport set -0.01 threshold set -[ flower6 ] start-shape set -cfdg-window ; +: init ( -- ) + [ ] >background + { -1 2 -1 2 } >viewport + 0.01 >threshold + [ flower6 ] >start-shape ; + +: run ( -- ) [ init ] cfdg-window. ; MAIN: run diff --git a/extra/cfdg/models/game1-turn6/game1-turn6.factor b/extra/cfdg/models/game1-turn6/game1-turn6.factor index 0cd65242fb..3e0994112a 100644 --- a/extra/cfdg/models/game1-turn6/game1-turn6.factor +++ b/extra/cfdg/models/game1-turn6/game1-turn6.factor @@ -37,11 +37,12 @@ DEFER: start ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run ( -- ) -[ 66 hue 0.4 sat 0.5 b ] >background -{ -5 10 -5 10 } viewport set -0.001 >threshold -[ start ] >start-shape -cfdg-window ; +: init ( -- ) + [ 66 hue 0.4 sat 0.5 b ] >background + { -5 10 -5 10 } >viewport + 0.001 >threshold + [ start ] >start-shape ; + +: run ( -- ) [ init ] cfdg-window. ; MAIN: run \ No newline at end of file diff --git a/extra/cfdg/models/lesson/lesson.factor b/extra/cfdg/models/lesson/lesson.factor index 287e572929..5902c121ae 100644 --- a/extra/cfdg/models/lesson/lesson.factor +++ b/extra/cfdg/models/lesson/lesson.factor @@ -96,12 +96,13 @@ iterate? [ ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run ( -- ) -[ ] >background -{ -5 25 -15 25 } viewport set -0.03 threshold set -[ toc ] start-shape set -cfdg-window ; +: init ( -- ) + [ ] >background + { -5 25 -15 25 } >viewport + 0.03 >threshold + [ toc ] >start-shape ; + +: run ( -- ) [ init ] cfdg-window. ; MAIN: run diff --git a/extra/cfdg/models/rules08/rules08.factor b/extra/cfdg/models/rules08/rules08.factor index d14aa04fb1..20099d225a 100644 --- a/extra/cfdg/models/rules08/rules08.factor +++ b/extra/cfdg/models/rules08/rules08.factor @@ -51,12 +51,13 @@ DEFER: line ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run ( -- ) +: init ( -- ) [ -1 b ] >background { -20 40 -20 40 } viewport set [ centre ] >start-shape - 0.0001 >threshold - cfdg-window ; + 0.0001 >threshold ; + +: run ( -- ) [ init ] cfdg-window. ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/cfdg/models/sierpinski/sierpinski.factor b/extra/cfdg/models/sierpinski/sierpinski.factor index 1acee8309a..2333506f29 100644 --- a/extra/cfdg/models/sierpinski/sierpinski.factor +++ b/extra/cfdg/models/sierpinski/sierpinski.factor @@ -26,14 +26,12 @@ iterate? [ ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run ( -- ) -[ ] >background -{ -4 8 -4 8 } viewport set -0.01 >threshold -[ top ] >start-shape -cfdg-window ; - -MAIN: run - +: init ( -- ) + [ ] >background + { -4 8 -4 8 } >viewport + 0.01 >threshold + [ top ] >start-shape ; +: run ( -- ) [ init ] cfdg-window. ; +MAIN: run \ No newline at end of file diff --git a/extra/cfdg/models/snowflake/snowflake.factor b/extra/cfdg/models/snowflake/snowflake.factor index 951f449e68..9efb3352fa 100644 --- a/extra/cfdg/models/snowflake/snowflake.factor +++ b/extra/cfdg/models/snowflake/snowflake.factor @@ -25,12 +25,13 @@ spike ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run ( -- ) -[ ] >background -{ -40 80 -40 80 } viewport set -0.1 threshold set -[ snowflake ] start-shape set -cfdg-window ; +: init ( -- ) + [ ] >background + { -40 80 -40 80 } >viewport + 0.1 >threshold + [ snowflake ] >start-shape ; + +: run ( -- ) [ init ] cfdg-window. ; MAIN: run diff --git a/extra/cfdg/models/spirales/spirales.factor b/extra/cfdg/models/spirales/spirales.factor new file mode 100644 index 0000000000..985c21643e --- /dev/null +++ b/extra/cfdg/models/spirales/spirales.factor @@ -0,0 +1,42 @@ + +USING: namespaces sequences math random-weighted cfdg ; + +IN: cfdg.models.spirales + +DEFER: line + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: block ( -- ) + [ + [ circle ] do + [ 0.3 s 60 flip line ] do + ] + recursive ; + +: a1 ( -- ) + [ + [ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] do + [ block ] do + ] + recursive ; + +: line ( -- ) + -0.3 a + [ 0 rotate a1 ] do + [ 120 rotate a1 ] do + [ 240 rotate a1 ] do ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: init ( -- ) + [ -1 b ] >background + { -20 40 -20 40 } viewport set + [ line ] >start-shape + 0.03 >threshold ; + +: run ( -- ) [ init ] cfdg-window. ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: run \ No newline at end of file diff --git a/extra/cfdg/models/spirales/tags.txt b/extra/cfdg/models/spirales/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/cfdg/models/spirales/tags.txt @@ -0,0 +1 @@ +demos diff --git a/extra/game-input/backend/backend.factor b/extra/game-input/backend/backend.factor index 451bbf1c34..a31b9d6649 100644 --- a/extra/game-input/backend/backend.factor +++ b/extra/game-input/backend/backend.factor @@ -1,8 +1,19 @@ -USING: kernel system combinators parser ; +USING: multiline system parser combinators ; IN: game-input.backend -<< { - { [ os macosx? ] [ "game-input.backend.iokit" use+ ] } - { [ os windows? ] [ "game-input.backend.dinput" use+ ] } +STRING: set-backend-for-macosx +USING: namespaces game-input.backend.iokit game-input ; +iokit-game-input-backend game-input-backend set-global +; + +STRING: set-backend-for-windows +USING: namespaces game-input.backend.dinput game-input ; +dinput-game-input-backend game-input-backend set-global +; + +{ + { [ os macosx? ] [ set-backend-for-macosx eval ] } + { [ os windows? ] [ set-backend-for-windows eval ] } { [ t ] [ ] } -} cond >> +} cond + diff --git a/extra/game-input/backend/dinput/dinput.factor b/extra/game-input/backend/dinput/dinput.factor index 69b2d41962..73c9f511a1 100755 --- a/extra/game-input/backend/dinput/dinput.factor +++ b/extra/game-input/backend/dinput/dinput.factor @@ -206,6 +206,13 @@ M: dinput-game-input-backend (close-game-input) close-device-change-window delete-dinput ; +M: dinput-game-input-backend (reset-game-input) + { + +dinput+ +keyboard-device+ +keyboard-state+ + +controller-devices+ +controller-guids+ + +device-change-window+ +device-change-handle+ + } [ f swap set-global ] each ; + M: dinput-game-input-backend get-controllers +controller-devices+ get [ drop controller boa ] { } assoc>map ; @@ -278,5 +285,3 @@ M: dinput-game-input-backend read-keyboard +keyboard-device+ get [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ] [ ] [ f ] with-acquisition ; - -dinput-game-input-backend game-input-backend set-global diff --git a/extra/game-input/backend/iokit/iokit.factor b/extra/game-input/backend/iokit/iokit.factor index 1871569227..dcdfa6d192 100755 --- a/extra/game-input/backend/iokit/iokit.factor +++ b/extra/game-input/backend/iokit/iokit.factor @@ -231,6 +231,10 @@ M: iokit-game-input-backend (open-game-input) ] } cleave ; +M: iokit-game-input-backend (reset-game-input) + { +hid-manager+ +keyboard-state+ +controller-states+ } + [ f swap set-global ] each ; + M: iokit-game-input-backend (close-game-input) +hid-manager+ get-global [ +hid-manager+ global [ @@ -271,5 +275,3 @@ M: iokit-game-input-backend read-keyboard ( -- keyboard-state ) M: iokit-game-input-backend calibrate-controller ( controller -- ) drop ; - -iokit-game-input-backend game-input-backend set-global diff --git a/extra/game-input/game-input.factor b/extra/game-input/game-input.factor index 4d25b06ead..208c8476fc 100755 --- a/extra/game-input/game-input.factor +++ b/extra/game-input/game-input.factor @@ -1,26 +1,34 @@ USING: arrays accessors continuations kernel symbols -combinators.lib sequences namespaces init ; +combinators.lib sequences namespaces init vocabs ; IN: game-input SYMBOLS: game-input-backend game-input-opened ; HOOK: (open-game-input) game-input-backend ( -- ) HOOK: (close-game-input) game-input-backend ( -- ) +HOOK: (reset-game-input) game-input-backend ( -- ) : game-input-opened? ( -- ? ) game-input-opened get ; - : open-game-input ( -- ) + load-game-input-backend game-input-opened? [ (open-game-input) game-input-opened on diff --git a/extra/html/streams/streams-tests.factor b/extra/html/streams/streams-tests.factor index 14f1621346..948c998e13 100644 --- a/extra/html/streams/streams-tests.factor +++ b/extra/html/streams/streams-tests.factor @@ -1,6 +1,8 @@ + USING: html.streams html.streams.private -io io.streams.string io.styles kernel -namespaces tools.test xml.writer sbufs sequences inspector ; + io io.streams.string io.styles kernel + namespaces tools.test xml.writer sbufs sequences inspector colors ; + IN: html.streams.tests : make-html-string @@ -52,7 +54,7 @@ M: funky browser-link-href [ [ "car" - H{ { foreground { 1 0 1 1 } } } + H{ { foreground T{ rgba f 1 0 1 1 } } } format ] make-html-string ] unit-test @@ -60,7 +62,7 @@ M: funky browser-link-href [ "
cdr
" ] [ [ - H{ { page-color { 1 0 1 1 } } } + H{ { page-color T{ rgba f 1 0 1 1 } } } [ "cdr" write ] with-nesting ] make-html-string ] unit-test diff --git a/extra/html/streams/streams.factor b/extra/html/streams/streams.factor index eae13f53ad..d21c743dcd 100755 --- a/extra/html/streams/streams.factor +++ b/extra/html/streams/streams.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: generic assocs help http io io.styles io.files continuations -io.streams.string kernel math math.order math.parser namespaces -quotations assocs sequences strings words html.elements -xml.entities sbufs continuations destructors accessors ; + +USING: combinators generic assocs help http io io.styles io.files + continuations io.streams.string kernel math math.order math.parser + namespaces quotations assocs sequences strings words html.elements + xml.entities sbufs continuations destructors accessors arrays ; + IN: html.streams GENERIC: browser-link-href ( presented -- href ) @@ -47,9 +49,9 @@ TUPLE: html-sub-stream < html-stream style parent ; ] [ call ] if* ] [ call ] if* ; inline -: hex-color, ( triplet -- ) - 3 head-slice - [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ; +: hex-color, ( color -- ) + [ red>> ] [ green>> ] [ blue>> ] tri + [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] tri@ ; : fg-css, ( color -- ) "color: #" % hex-color, "; " % ; diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index e021ff4ff4..1b338df442 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -160,7 +160,7 @@ IN: irc.client.tests } cleave ] unit-test -! Namelist notification +! Namelist change notification { T{ participant-changed f f f } } [ { ":ircserver.net 353 factorbot @ #factortest :@factorbot " ":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client @@ -172,4 +172,19 @@ IN: irc.client.tests [ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ] [ terminate-irc ] } cleave + ] unit-test + +{ T{ participant-changed f "somedude" +part+ } } [ + { ":somedude!n=user@isp.net QUIT" } make-client + { [ "factorbot" set-nick ] + [ listeners>> + [ "#factortest" [ + H{ { "somedude" +normal+ } } clone >>participants ] keep + ] dip set-at ] + [ connect-irc ] + [ drop 0.1 seconds sleep ] + [ listeners>> [ "#factortest" ] dip at + [ read-message drop ] [ read-message drop ] [ read-message ] tri ] + [ terminate-irc ] + } cleave ] unit-test \ No newline at end of file diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 813de0f57c..99922b1fb5 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -88,10 +88,11 @@ SYMBOL: current-irc-client : irc-stream> ( -- stream ) irc> stream>> ; : irc-write ( s -- ) irc-stream> stream-write ; : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ; +: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ; : listener> ( name -- listener/f ) irc> listeners>> at ; : maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- ) - [ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline + [ dup mailbox-empty? [ drop 0.1 sleep ] ] dip '[ mailbox-get @ ] if ; inline GENERIC: to-listener ( message obj -- ) @@ -147,24 +148,6 @@ DEFER: me? "JOIN " irc-write [ [ " :" ] dip 3append ] when* irc-print ; -: /PART ( channel text -- ) - [ "PART " irc-write irc-write ] dip - " :" irc-write irc-print ; - -: /KICK ( channel who -- ) - [ "KICK " irc-write irc-write ] dip - " " irc-write irc-print ; - -: /PRIVMSG ( nick line -- ) - [ "PRIVMSG " irc-write irc-write ] dip - " :" irc-write irc-print ; - -: /ACTION ( nick line -- ) - [ 1 , "ACTION " % % 1 , ] "" make /PRIVMSG ; - -: /QUIT ( text -- ) - "QUIT :" irc-write irc-print ; - : /PONG ( text -- ) "PONG " irc-write irc-print ; @@ -240,10 +223,14 @@ M: kick handle-incoming-irc ( kick -- ) M: quit handle-incoming-irc ( quit -- ) [ dup prefix>> parse-name listeners-with-participant [ to-listener ] with each ] - [ prefix>> parse-name remove-participant-from-all ] [ handle-participant-change ] + [ prefix>> parse-name remove-participant-from-all ] tri ; +! FIXME: implement this +! M: mode handle-incoming-irc ( mode -- ) call-next-method ; +! M: nick handle-incoming-irc ( nick -- ) call-next-method ; + : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 662fca6d79..a524168d54 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -2,13 +2,14 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel threads combinators concurrency.mailboxes - sequences strings hashtables splitting fry assocs hashtables + sequences strings hashtables splitting fry assocs hashtables colors + sorting qualified unicode.collation math.order ui ui.gadgets ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels io io.styles namespaces calendar calendar.format models continuations irc.client irc.client.private irc.messages irc.messages.private - irc.ui.commandparser irc.ui.load qualified ; + irc.ui.commandparser irc.ui.load ; RENAME: join sequences => sjoin @@ -24,14 +25,8 @@ TUPLE: irc-tab < frame listener client userlist ; : write-color ( str color -- ) foreground associate format ; -: red { 0.5 0 0 1 } ; -: green { 0 0.5 0 1 } ; -: blue { 0 0 1 1 } ; -: black { 0 0 0 1 } ; - -: colors H{ { +operator+ { 0 0.5 0 1 } } - { +voice+ { 0 0 1 1 } } - { +normal+ { 0 0 0 1 } } } ; +: dark-red T{ rgba f 0.5 0.0 0.0 1 } ; +: dark-green T{ rgba f 0.0 0.5 0.0 1 } ; : dot-or-parens ( string -- string ) dup empty? [ drop "." ] @@ -65,21 +60,29 @@ M: own-message write-irc message>> write ; M: join write-irc - "* " green write-color + "* " dark-green write-color prefix>> parse-name write - " has entered the channel." green write-color ; + " has entered the channel." dark-green write-color ; M: part write-irc - "* " red write-color + "* " dark-red write-color [ prefix>> parse-name write ] keep - " has left the channel" red write-color - trailing>> dot-or-parens red write-color ; + " has left the channel" dark-red write-color + trailing>> dot-or-parens dark-red write-color ; M: quit write-irc - "* " red write-color + "* " dark-red write-color [ prefix>> parse-name write ] keep - " has left IRC" red write-color - trailing>> dot-or-parens red write-color ; + " has left IRC" dark-red write-color + trailing>> dot-or-parens dark-red write-color ; + +M: kick write-irc + "* " dark-red write-color + [ prefix>> parse-name write ] keep + " has kicked " dark-red write-color + [ who>> write ] keep + " from the channel" dark-red write-color + trailing>> dot-or-parens dark-red write-color ; : full-mode ( message -- mode ) parameters>> rest " " sjoin ; @@ -92,18 +95,24 @@ M: mode write-irc " to " blue write-color channel>> write ; +M: nick write-irc + "* " blue write-color + [ prefix>> parse-name write ] keep + " is now known as " blue write-color + trailing>> write ; + M: unhandled write-irc "UNHANDLED: " write line>> blue write-color ; M: irc-end write-irc - drop "* You have left IRC" red write-color ; + drop "* You have left IRC" dark-red write-color ; M: irc-disconnected write-irc - drop "* Disconnected" red write-color ; + drop "* Disconnected" dark-red write-color ; M: irc-connected write-irc - drop "* Connected" green write-color ; + drop "* Connected" dark-green write-color ; M: irc-listener-end write-irc drop ; @@ -124,15 +133,18 @@ M: irc-message write-irc GENERIC: handle-inbox ( tab message -- ) -: filter-participants ( pack alist val color -- pack ) - '[ , = [