Merge branch 'master' of git://factorcode.org/git/factor
Bruno Deferrari
commit
ec16d1eb1b
|
|
@ -30,10 +30,3 @@ words splitting grouping sorting ;
|
|||
\ + stack-trace-contains?
|
||||
\ > stack-trace-contains?
|
||||
] unit-test
|
||||
|
||||
: quux ( -- seq ) { 1 2 3 } [ "hi" throw ] sort ;
|
||||
|
||||
[ t ] [
|
||||
[ 10 quux ] ignore-errors
|
||||
\ sort stack-trace-contains?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -219,7 +219,7 @@ M: number detect-number ;
|
|||
|
||||
! Regression
|
||||
USE: sorting
|
||||
USE: sorting.private
|
||||
USE: binary-search.private
|
||||
|
||||
: old-binsearch ( elt quot seq -- elt quot i )
|
||||
dup length 1 <= [
|
||||
|
|
@ -227,7 +227,7 @@ USE: sorting.private
|
|||
] [
|
||||
[ midpoint swap call ] 3keep roll dup zero?
|
||||
[ drop dup slice-from swap midpoint@ + ]
|
||||
[ partition old-binsearch ] if
|
||||
[ dup midpoint@ cut-slice old-binsearch ] if
|
||||
] if ; inline
|
||||
|
||||
[ 10 ] [
|
||||
|
|
|
|||
|
|
@ -3,6 +3,10 @@ sequences math.order ;
|
|||
IN: sorting
|
||||
|
||||
ARTICLE: "sequences-sorting" "Sorting sequences"
|
||||
"The " { $vocab-link "sorting" } " vocabulary implements the merge-sort algorithm. It runs in " { $snippet "O(n log n)" } " time, and is a " { $emphasis "stable" } " sort, meaning that the order of equal elements is preserved."
|
||||
$nl
|
||||
"The algorithm only allocates two additional arrays, both the size of the input sequence, and uses iteration rather than recursion, and thus is suitable for sorting large sequences."
|
||||
$nl
|
||||
"Sorting combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "."
|
||||
$nl
|
||||
"Sorting a sequence with a custom comparator:"
|
||||
|
|
|
|||
|
|
@ -18,3 +18,9 @@ unit-test
|
|||
] unit-test
|
||||
|
||||
[ ] [ { 1 2 } [ 2drop 1 ] sort drop ] unit-test
|
||||
|
||||
! Is it a stable sort?
|
||||
[ t ] [ { { 1 "a" } { 1 "b" } { 1 "c" } } dup sort-keys = ] unit-test
|
||||
|
||||
[ { { 1 "a" } { 1 "b" } { 1 "c" } { 1 "e" } { 2 "d" } } ]
|
||||
[ { { 1 "a" } { 1 "b" } { 1 "c" } { 2 "d" } { 1 "e" } } sort-keys ] unit-test
|
||||
|
|
|
|||
|
|
@ -24,11 +24,23 @@ TUPLE: merge
|
|||
{ to2 array-capacity } ;
|
||||
|
||||
: dump ( from to seq accum -- )
|
||||
#! Optimize common case where to - from = 1.
|
||||
>r >r 2dup swap - 1 =
|
||||
[ drop r> nth-unsafe r> push ]
|
||||
[ r> <slice> r> push-all ]
|
||||
if ; inline
|
||||
#! Optimize common case where to - from = 1, 2, or 3.
|
||||
>r >r 2dup swap - dup 1 =
|
||||
[ 2drop r> nth-unsafe r> push ] [
|
||||
dup 2 = [
|
||||
2drop dup 1+
|
||||
r> [ nth-unsafe ] curry bi@
|
||||
r> [ push ] curry bi@
|
||||
] [
|
||||
dup 3 = [
|
||||
2drop dup 1+ dup 1+
|
||||
r> [ nth-unsafe ] curry tri@
|
||||
r> [ push ] curry tri@
|
||||
] [
|
||||
drop r> subseq r> push-all
|
||||
] if
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
: l-elt [ from1>> ] [ seq>> ] bi nth-unsafe ; inline
|
||||
: r-elt [ from2>> ] [ seq>> ] bi nth-unsafe ; inline
|
||||
|
|
@ -38,13 +50,13 @@ TUPLE: merge
|
|||
: dump-r [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
|
||||
: l-next [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
|
||||
: r-next [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
|
||||
: decide [ [ l-elt ] [ r-elt ] bi ] dip call +lt+ eq? ; inline
|
||||
: decide [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
|
||||
|
||||
: (merge) ( merge quot -- )
|
||||
over l-done? [ drop dump-r ] [
|
||||
over r-done? [ drop dump-l ] [
|
||||
over r-done? [ drop dump-l ] [
|
||||
over l-done? [ drop dump-r ] [
|
||||
2dup decide
|
||||
[ over l-next ] [ over r-next ] if
|
||||
[ over r-next ] [ over l-next ] if
|
||||
(merge)
|
||||
] if
|
||||
] if ; inline
|
||||
|
|
|
|||
|
|
@ -6,7 +6,6 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
|
|||
ui
|
||||
ui.gestures
|
||||
ui.gadgets
|
||||
ui.gadgets.handler
|
||||
ui.gadgets.slate
|
||||
ui.gadgets.labels
|
||||
ui.gadgets.buttons
|
||||
|
|
@ -14,6 +13,7 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
|
|||
ui.gadgets.packs
|
||||
ui.gadgets.grids
|
||||
ui.gadgets.theme
|
||||
ui.gadgets.handler
|
||||
accessors
|
||||
qualified
|
||||
namespaces.lib assocs.lib vars
|
||||
|
|
@ -83,11 +83,13 @@ DEFER: automata-window
|
|||
@top grid-add
|
||||
|
||||
C[ display ] <slate>
|
||||
{ 400 400 } >>dim
|
||||
{ 400 400 } >>pdim
|
||||
dup >slate
|
||||
|
||||
@center grid-add
|
||||
|
||||
<handler>
|
||||
|
||||
H{ }
|
||||
T{ key-down f f "1" } [ start-center ] view-action is
|
||||
T{ key-down f f "2" } [ start-random ] view-action is
|
||||
|
|
@ -95,9 +97,7 @@ DEFER: automata-window
|
|||
T{ key-down f f "5" } [ random-rule ] view-action is
|
||||
T{ key-down f f "n" } [ automata-window ] view-action is
|
||||
|
||||
<handler>
|
||||
|
||||
tuck set-gadget-delegate
|
||||
>>table
|
||||
|
||||
"Automata" open-window ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,67 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: backtrack shuffle math math.ranges quotations locals fry
|
||||
kernel words io memoize macros io prettyprint sequences assocs
|
||||
combinators namespaces ;
|
||||
IN: benchmark.backtrack
|
||||
|
||||
! This was suggested by Dr_Ford. Compute the number of quadruples
|
||||
! (a,b,c,d) with 1 <= a,b,c,d <= 10 such that we can make 24 by
|
||||
! placing them on the stack, and applying the operations
|
||||
! +, -, * and rot as many times as we wish.
|
||||
|
||||
: nop ;
|
||||
|
||||
MACRO: amb-execute ( seq -- quot )
|
||||
[ length ] [ <enum> [ 1quotation ] assoc-map ] bi
|
||||
'[ , amb , case ] ;
|
||||
|
||||
: if-amb ( true false -- )
|
||||
[
|
||||
[ { t f } amb ]
|
||||
[ '[ @ require t ] ]
|
||||
[ '[ @ f ] ]
|
||||
tri* if
|
||||
] with-scope ; inline
|
||||
|
||||
: do-something ( a b -- c )
|
||||
{ + - * } amb-execute ;
|
||||
|
||||
: some-rots ( a b c -- a b c )
|
||||
#! Try to rot 0, 1 or 2 times.
|
||||
{ nop rot -rot } amb-execute ;
|
||||
|
||||
MEMO: 24-from-1 ( a -- ? )
|
||||
24 = ;
|
||||
|
||||
MEMO: 24-from-2 ( a b -- ? )
|
||||
[ do-something 24-from-1 ] [ 2drop ] if-amb ;
|
||||
|
||||
MEMO: 24-from-3 ( a b c -- ? )
|
||||
[ some-rots do-something 24-from-2 ] [ 3drop ] if-amb ;
|
||||
|
||||
MEMO: 24-from-4 ( a b c d -- ? )
|
||||
[ some-rots do-something 24-from-3 ] [ 4drop ] if-amb ;
|
||||
|
||||
: find-impossible-24 ( -- n )
|
||||
1 10 [a,b] [| a |
|
||||
1 10 [a,b] [| b |
|
||||
1 10 [a,b] [| c |
|
||||
1 10 [a,b] [| d |
|
||||
a b c d 24-from-4
|
||||
] count
|
||||
] sigma
|
||||
] sigma
|
||||
] sigma ;
|
||||
|
||||
: words { 24-from-1 24-from-2 24-from-3 24-from-4 } ;
|
||||
|
||||
: backtrack-benchmark ( -- )
|
||||
words [ reset-memoized ] each
|
||||
find-impossible-24 pprint "/10000 quadruples can make 24." print
|
||||
words [
|
||||
dup pprint " tested " write "memoize" word-prop assoc-size pprint
|
||||
" possibilities" print
|
||||
] each ;
|
||||
|
||||
MAIN: backtrack-benchmark
|
||||
|
|
@ -102,7 +102,7 @@ VARS: population-label cohesion-label alignment-label separation-label ;
|
|||
|
||||
C[ display ] <slate> >slate
|
||||
t slate> set-gadget-clipped?
|
||||
{ 600 400 } slate> set-slate-dim
|
||||
{ 600 400 } slate> set-slate-pdim
|
||||
C[ [ run ] in-thread ] slate> set-slate-graft
|
||||
C[ loop off ] slate> set-slate-ungraft
|
||||
|
||||
|
|
@ -147,6 +147,8 @@ VARS: population-label cohesion-label alignment-label separation-label ;
|
|||
|
||||
slate> over @center grid-add
|
||||
|
||||
<handler>
|
||||
|
||||
H{ } clone
|
||||
T{ key-down f f "1" } C[ drop randomize ] is
|
||||
T{ key-down f f "2" } C[ drop sub-10-boids ] is
|
||||
|
|
@ -162,7 +164,10 @@ VARS: population-label cohesion-label alignment-label separation-label ;
|
|||
T{ key-down f f "d" } C[ drop dec-separation-weight ] is
|
||||
|
||||
T{ key-down f f "ESC" } C[ drop toggle-loop ] is
|
||||
<handler> tuck set-gadget-delegate "Boids" open-window ;
|
||||
|
||||
>>table
|
||||
|
||||
"Boids" open-window ;
|
||||
|
||||
: boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;
|
||||
|
||||
|
|
|
|||
|
|
@ -204,7 +204,7 @@ VAR: start-shape
|
|||
|
||||
: cfdg-window* ( -- )
|
||||
[ display ] closed-quot <slate>
|
||||
{ 500 500 } over set-slate-dim
|
||||
{ 500 500 } over set-slate-pdim
|
||||
dup "CFDG" open-window ;
|
||||
|
||||
: cfdg-window ( -- ) [ cfdg-window* ] with-ui ;
|
||||
|
|
@ -17,7 +17,7 @@ IN: channels.tests
|
|||
from
|
||||
] unit-test
|
||||
|
||||
{ V{ 1 2 3 4 } } [
|
||||
{ { 1 2 3 4 } } [
|
||||
V{ } clone <channel>
|
||||
[ from swap push ] in-thread
|
||||
[ from swap push ] in-thread
|
||||
|
|
@ -30,7 +30,7 @@ IN: channels.tests
|
|||
natural-sort
|
||||
] unit-test
|
||||
|
||||
{ V{ 1 2 4 9 } } [
|
||||
{ { 1 2 4 9 } } [
|
||||
V{ } clone <channel>
|
||||
[ 4 swap to ] in-thread
|
||||
[ 2 swap to ] in-thread
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: alien strings arrays help.markup help.syntax ;
|
||||
USING: alien strings arrays help.markup help.syntax destructors ;
|
||||
IN: core-foundation
|
||||
|
||||
HELP: CF>array
|
||||
|
|
@ -37,6 +37,16 @@ HELP: load-framework
|
|||
{ $values { "name" "a pathname string" } }
|
||||
{ $description "Loads a Core Foundation framework." } ;
|
||||
|
||||
HELP: &CFRelease
|
||||
{ $values { "alien" "Pointer to a Core Foundation object" } }
|
||||
{ $description "Marks the given Core Foundation object for unconditional release via " { $link CFRelease } " at the end of the enclosing " { $link with-destructors } " scope." } ;
|
||||
|
||||
HELP: |CFRelease
|
||||
{ $values { "interface" "Pointer to a Core Foundation object" } }
|
||||
{ $description "Marks the given Core Foundation object for release via " { $link CFRelease } " in the event of an error at the end of the enclosing " { $link with-destructors } " scope." } ;
|
||||
|
||||
{ CFRelease |CFRelease &CFRelease } related-words
|
||||
|
||||
ARTICLE: "core-foundation" "Core foundation utilities"
|
||||
"The " { $vocab-link "core-foundation" } " vocabulary defines bindings for some frequently-used Core Foundation functions. It also provides some utility words."
|
||||
$nl
|
||||
|
|
@ -51,7 +61,9 @@ $nl
|
|||
{ $subsection <CFFileSystemURL> }
|
||||
{ $subsection <CFURL> }
|
||||
"Frameworks:"
|
||||
{ $subsection load-framework } ;
|
||||
{ $subsection load-framework }
|
||||
"Memory management:"
|
||||
{ $subsection &CFRelease }
|
||||
{ $subsection |CFRelease } ;
|
||||
|
||||
IN: core-foundation
|
||||
ABOUT: "core-foundation"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.strings alien.syntax kernel
|
||||
math sequences io.encodings.utf16 ;
|
||||
math sequences io.encodings.utf16 destructors accessors ;
|
||||
IN: core-foundation
|
||||
|
||||
TYPEDEF: void* CFAllocatorRef
|
||||
|
|
@ -135,3 +135,9 @@ M: f <CFNumber>
|
|||
"Cannot load bundled named " prepend throw
|
||||
] ?if ;
|
||||
|
||||
TUPLE: CFRelease-destructor alien disposed ;
|
||||
M: CFRelease-destructor dispose* alien>> CFRelease ;
|
||||
: &CFRelease ( alien -- alien )
|
||||
dup f CFRelease-destructor boa &dispose drop ; inline
|
||||
: |CFRelease ( alien -- alien )
|
||||
dup f CFRelease-destructor boa |dispose drop ; inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1,43 @@
|
|||
|
||||
USING: kernel namespaces sequences math
|
||||
listener io prettyprint sequences.lib fry ;
|
||||
|
||||
IN: display-stack
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: watched-variables
|
||||
|
||||
: watch-var ( sym -- ) watched-variables get push ;
|
||||
|
||||
: watch-vars ( seq -- ) watched-variables get [ push ] curry each ;
|
||||
|
||||
: unwatch-var ( sym -- ) watched-variables get delete ;
|
||||
|
||||
: unwatch-vars ( seq -- ) watched-variables get [ delete ] curry each ;
|
||||
|
||||
: print-watched-variables ( -- )
|
||||
watched-variables get length 0 >
|
||||
[
|
||||
"----------" print
|
||||
watched-variables get
|
||||
watched-variables get [ unparse ] map longest length 2 +
|
||||
'[ [ unparse ": " append , 32 pad-right write ] [ get . ] bi ]
|
||||
each
|
||||
|
||||
]
|
||||
when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: display-stack ( -- )
|
||||
V{ } clone watched-variables set
|
||||
[
|
||||
print-watched-variables
|
||||
"----------" print
|
||||
datastack [ . ] each
|
||||
"----------" print
|
||||
retainstack reverse [ . ] each
|
||||
]
|
||||
listener-hook set ;
|
||||
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
Doug Coleman
|
||||
Slava Pestov
|
||||
|
|
@ -1 +1,2 @@
|
|||
Doug Coleman
|
||||
Slava Pestov
|
||||
|
|
|
|||
|
|
@ -1,12 +1,19 @@
|
|||
USING: farkup kernel tools.test ;
|
||||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: farkup kernel peg peg.ebnf tools.test ;
|
||||
IN: farkup.tests
|
||||
|
||||
[ "<ul><li>foo</li></ul>" ] [ "-foo" convert-farkup ] unit-test
|
||||
[ "<ul><li>foo</li></ul>\n" ] [ "-foo\n" convert-farkup ] unit-test
|
||||
[ "<ul><li>foo</li><li>bar</li></ul>" ] [ "-foo\n-bar" convert-farkup ] unit-test
|
||||
[ "<ul><li>foo</li><li>bar</li></ul>\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
|
||||
[ ] [
|
||||
"abcd-*strong*\nasdifj\nweouh23ouh23"
|
||||
"paragraph" \ farkup rule parse drop
|
||||
] unit-test
|
||||
|
||||
[ "<ul><li>foo</li></ul>\n<p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
|
||||
[ ] [
|
||||
"abcd-*strong*\nasdifj\nweouh23ouh23\n"
|
||||
"paragraph" \ farkup rule parse drop
|
||||
] unit-test
|
||||
|
||||
[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
|
||||
[ "<p>*foo\nbar\n</p>" ] [ "*foo\nbar\n" convert-farkup ] unit-test
|
||||
[ "<p><strong>Wow!</strong></p>" ] [ "*Wow!*" convert-farkup ] unit-test
|
||||
[ "<p><em>Wow.</em></p>" ] [ "_Wow._" convert-farkup ] unit-test
|
||||
|
|
@ -15,11 +22,20 @@ IN: farkup.tests
|
|||
[ "<p>*</p>" ] [ "\\*" convert-farkup ] unit-test
|
||||
[ "<p>**</p>" ] [ "\\**" convert-farkup ] unit-test
|
||||
|
||||
[ "" ] [ "\n\n" convert-farkup ] unit-test
|
||||
[ "" ] [ "\r\n\r\n" convert-farkup ] unit-test
|
||||
[ "" ] [ "\r\r\r\r" convert-farkup ] unit-test
|
||||
[ "\n" ] [ "\r\r\r" convert-farkup ] unit-test
|
||||
[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test
|
||||
[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test
|
||||
[ "<ul><li>foo</li></ul>" ] [ "-foo" convert-farkup ] unit-test
|
||||
[ "<ul><li>foo</li>\n</ul>" ] [ "-foo\n" convert-farkup ] unit-test
|
||||
[ "<ul><li>foo</li>\n<li>bar</li></ul>" ] [ "-foo\n-bar" convert-farkup ] unit-test
|
||||
[ "<ul><li>foo</li>\n<li>bar</li>\n</ul>" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<ul><li>foo</li>\n</ul><p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
|
||||
|
||||
|
||||
[ "\n\n" ] [ "\n\n" convert-farkup ] unit-test
|
||||
[ "\n\n" ] [ "\r\n\r\n" convert-farkup ] unit-test
|
||||
[ "\n\n\n\n" ] [ "\r\r\r\r" convert-farkup ] unit-test
|
||||
[ "\n\n\n" ] [ "\r\r\r" convert-farkup ] unit-test
|
||||
[ "\n\n\n" ] [ "\n\n\n" convert-farkup ] unit-test
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test
|
||||
|
|
@ -29,7 +45,7 @@ IN: farkup.tests
|
|||
[ "\n<p>bar\n</p>" ] [ "\rbar\r" convert-farkup ] unit-test
|
||||
[ "\n<p>bar\n</p>" ] [ "\r\nbar\r\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>foo</p>\n<p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
|
||||
|
||||
[ "" ] [ "" convert-farkup ] unit-test
|
||||
|
||||
|
|
@ -77,8 +93,5 @@ IN: farkup.tests
|
|||
] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
|
||||
|
||||
[
|
||||
"<p>Feature comparison:\n\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
|
||||
"<p>Feature comparison:</p><table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table>"
|
||||
] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
|
||||
[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,72 +1,111 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays io io.styles kernel memoize namespaces peg math
|
||||
combinators sequences strings html.elements xml.entities
|
||||
xmode.code2html splitting io.streams.string peg.parsers
|
||||
sequences.deep unicode.categories ;
|
||||
USING: accessors arrays combinators html.elements io io.streams.string
|
||||
kernel math memoize namespaces peg peg.ebnf prettyprint
|
||||
sequences sequences.deep strings xml.entities vectors splitting
|
||||
xmode.code2html ;
|
||||
IN: farkup
|
||||
|
||||
SYMBOL: relative-link-prefix
|
||||
SYMBOL: disable-images?
|
||||
SYMBOL: link-no-follow?
|
||||
|
||||
<PRIVATE
|
||||
TUPLE: heading1 obj ;
|
||||
TUPLE: heading2 obj ;
|
||||
TUPLE: heading3 obj ;
|
||||
TUPLE: heading4 obj ;
|
||||
TUPLE: strong obj ;
|
||||
TUPLE: emphasis obj ;
|
||||
TUPLE: superscript obj ;
|
||||
TUPLE: subscript obj ;
|
||||
TUPLE: inline-code obj ;
|
||||
TUPLE: paragraph obj ;
|
||||
TUPLE: list-item obj ;
|
||||
TUPLE: list obj ;
|
||||
TUPLE: table obj ;
|
||||
TUPLE: table-row obj ;
|
||||
TUPLE: link href text ;
|
||||
TUPLE: image href text ;
|
||||
TUPLE: code mode string ;
|
||||
|
||||
: delimiters ( -- string )
|
||||
"*_^~%[-=|\\\r\n" ; inline
|
||||
EBNF: farkup
|
||||
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
|
||||
2nl = nl nl
|
||||
|
||||
MEMO: text ( -- parser )
|
||||
[ delimiters member? not ] satisfy repeat1
|
||||
[ >string escape-string ] action ;
|
||||
heading1 = "=" (!("=" | nl).)+ "="
|
||||
=> [[ second >string heading1 boa ]]
|
||||
|
||||
MEMO: delimiter ( -- parser )
|
||||
[ dup delimiters member? swap "\r\n=" member? not and ] satisfy
|
||||
[ 1string ] action ;
|
||||
heading2 = "==" (!("=" | nl).)+ "=="
|
||||
=> [[ second >string heading2 boa ]]
|
||||
|
||||
: surround-with-foo ( string tag -- seq )
|
||||
dup <foo> swap </foo> swapd 3array ;
|
||||
heading3 = "===" (!("=" | nl).)+ "==="
|
||||
=> [[ second >string heading3 boa ]]
|
||||
|
||||
: delimited ( str html -- parser )
|
||||
[
|
||||
over token hide ,
|
||||
text [ surround-with-foo ] swapd curry action ,
|
||||
token hide ,
|
||||
] seq* ;
|
||||
heading4 = "====" (!("=" | nl).)+ "===="
|
||||
=> [[ second >string heading4 boa ]]
|
||||
|
||||
MEMO: escaped-char ( -- parser )
|
||||
[ "\\" token hide , any-char , ] seq* [ >string ] action ;
|
||||
strong = "*" (!("*" | nl).)+ "*"
|
||||
=> [[ second >string strong boa ]]
|
||||
|
||||
MEMO: strong ( -- parser ) "*" "strong" delimited ;
|
||||
MEMO: emphasis ( -- parser ) "_" "em" delimited ;
|
||||
MEMO: superscript ( -- parser ) "^" "sup" delimited ;
|
||||
MEMO: subscript ( -- parser ) "~" "sub" delimited ;
|
||||
MEMO: inline-code ( -- parser ) "%" "code" delimited ;
|
||||
MEMO: nl ( -- parser )
|
||||
"\r\n" token [ drop "\n" ] action
|
||||
"\r" token [ drop "\n" ] action
|
||||
"\n" token 3choice ;
|
||||
MEMO: 2nl ( -- parser ) nl hide nl hide 2seq ;
|
||||
MEMO: h1 ( -- parser ) "=" "h1" delimited ;
|
||||
MEMO: h2 ( -- parser ) "==" "h2" delimited ;
|
||||
MEMO: h3 ( -- parser ) "===" "h3" delimited ;
|
||||
MEMO: h4 ( -- parser ) "====" "h4" delimited ;
|
||||
emphasis = "_" (!("_" | nl).)+ "_"
|
||||
=> [[ second >string emphasis boa ]]
|
||||
|
||||
superscript = "^" (!("^" | nl).)+ "^"
|
||||
=> [[ second >string superscript boa ]]
|
||||
|
||||
subscript = "~" (!("~" | nl).)+ "~"
|
||||
=> [[ second >string subscript boa ]]
|
||||
|
||||
inline-code = "%" (!("%" | nl).)+ "%"
|
||||
=> [[ second >string inline-code boa ]]
|
||||
|
||||
escaped-char = "\" . => [[ second ]]
|
||||
|
||||
image-link = "[[image:" (!("|") .)+ "|" (!("]]").)+ "]]"
|
||||
=> [[ [ second >string ] [ fourth >string ] bi image boa ]]
|
||||
| "[[image:" (!("]").)+ "]]"
|
||||
=> [[ second >string f image boa ]]
|
||||
|
||||
simple-link = "[[" (!("|]" | "]]") .)+ "]]"
|
||||
=> [[ second >string dup link boa ]]
|
||||
|
||||
labelled-link = "[[" (!("|") .)+ "|" (!("]]").)+ "]]"
|
||||
=> [[ [ second >string ] [ fourth >string ] bi link boa ]]
|
||||
|
||||
link = image-link | labelled-link | simple-link
|
||||
|
||||
heading = heading4 | heading3 | heading2 | heading1
|
||||
|
||||
inline-tag = strong | emphasis | superscript | subscript | inline-code
|
||||
| link | escaped-char
|
||||
|
||||
inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '['
|
||||
|
||||
table-column = (list | (!(nl | inline-delimiter | '|').)+ | inline-tag | inline-delimiter ) '|'
|
||||
=> [[ first ]]
|
||||
table-row = "|" (table-column)+
|
||||
=> [[ second table-row boa ]]
|
||||
table = ((table-row nl => [[ first ]] )+ table-row? | table-row)
|
||||
=> [[ table boa ]]
|
||||
|
||||
paragraph-item = ( table | (!(nl | code | heading | inline-delimiter | table ).) | inline-tag | inline-delimiter)+
|
||||
paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]]
|
||||
| (paragraph-item nl)+ paragraph-item?
|
||||
| paragraph-item)
|
||||
=> [[ paragraph boa ]]
|
||||
|
||||
list-item = '-' ((!(inline-delimiter | nl).)+ | inline-tag)*
|
||||
=> [[ second list-item boa ]]
|
||||
list = ((list-item nl)+ list-item? | list-item)
|
||||
=> [[ list boa ]]
|
||||
|
||||
code = '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]"
|
||||
=> [[ [ second >string ] [ fourth >string ] bi code boa ]]
|
||||
|
||||
stand-alone = (code | heading | list | table | paragraph | nl)*
|
||||
;EBNF
|
||||
|
||||
MEMO: eq ( -- parser )
|
||||
[
|
||||
h1 ensure-not ,
|
||||
h2 ensure-not ,
|
||||
h3 ensure-not ,
|
||||
h4 ensure-not ,
|
||||
"=" token ,
|
||||
] seq* ;
|
||||
|
||||
: render-code ( string mode -- string' )
|
||||
>r string-lines r>
|
||||
[
|
||||
<pre>
|
||||
htmlize-lines
|
||||
</pre>
|
||||
] with-string-writer ;
|
||||
|
||||
: invalid-url "javascript:alert('Invalid URL in farkup');" ;
|
||||
|
||||
|
|
@ -85,116 +124,57 @@ MEMO: eq ( -- parser )
|
|||
: escape-link ( href text -- href-esc text-esc )
|
||||
>r check-url escape-quoted-string r> escape-string ;
|
||||
|
||||
: make-link ( href text -- seq )
|
||||
: write-link ( text href -- )
|
||||
escape-link
|
||||
[
|
||||
"<a" ,
|
||||
" href=\"" , >r , r> "\"" ,
|
||||
link-no-follow? get [ " nofollow=\"true\"" , ] when
|
||||
">" , , "</a>" ,
|
||||
] { } make ;
|
||||
"<a" write
|
||||
" href=\"" write write "\"" write
|
||||
link-no-follow? get [ " nofollow=\"true\"" write ] when
|
||||
">" write write "</a>" write ;
|
||||
|
||||
: make-image-link ( href alt -- seq )
|
||||
: write-image-link ( href text -- )
|
||||
disable-images? get [
|
||||
2drop "<strong>Images are not allowed</strong>"
|
||||
2drop "<strong>Images are not allowed</strong>" write
|
||||
] [
|
||||
escape-link
|
||||
[
|
||||
"<img src=\"" , swap , "\"" ,
|
||||
dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
|
||||
"/>" ,
|
||||
] { } make
|
||||
>r "<img src=\"" write write "\"" write r>
|
||||
dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if
|
||||
"/>" write
|
||||
] if ;
|
||||
|
||||
MEMO: image-link ( -- parser )
|
||||
: render-code ( string mode -- string' )
|
||||
>r string-lines r>
|
||||
[
|
||||
"[[image:" token hide ,
|
||||
[ "|]" member? not ] satisfy repeat1 [ >string ] action ,
|
||||
"|" token hide
|
||||
[ CHAR: ] = not ] satisfy repeat0 2seq
|
||||
[ first >string ] action optional ,
|
||||
"]]" token hide ,
|
||||
] seq* [ first2 make-image-link ] action ;
|
||||
<pre>
|
||||
htmlize-lines
|
||||
</pre>
|
||||
] with-string-writer write ;
|
||||
|
||||
MEMO: simple-link ( -- parser )
|
||||
[
|
||||
"[[" token hide ,
|
||||
[ "|]" member? not ] satisfy repeat1 ,
|
||||
"]]" token hide ,
|
||||
] seq* [ first dup make-link ] action ;
|
||||
|
||||
MEMO: labelled-link ( -- parser )
|
||||
[
|
||||
"[[" token hide ,
|
||||
[ CHAR: | = not ] satisfy repeat1 ,
|
||||
"|" token hide ,
|
||||
[ CHAR: ] = not ] satisfy repeat1 ,
|
||||
"]]" token hide ,
|
||||
] seq* [ first2 make-link ] action ;
|
||||
|
||||
MEMO: link ( -- parser )
|
||||
[ image-link , simple-link , labelled-link , ] choice* ;
|
||||
|
||||
DEFER: line
|
||||
MEMO: list-item ( -- parser )
|
||||
[
|
||||
"-" token hide , ! text ,
|
||||
[ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action ,
|
||||
] seq* [ "li" surround-with-foo ] action ;
|
||||
|
||||
MEMO: list ( -- parser )
|
||||
list-item nl hide list-of
|
||||
[ "ul" surround-with-foo ] action ;
|
||||
|
||||
MEMO: table-column ( -- parser )
|
||||
text [ "td" surround-with-foo ] action ;
|
||||
|
||||
MEMO: table-row ( -- parser )
|
||||
"|" token hide
|
||||
table-column "|" token hide list-of
|
||||
"|" token hide nl hide optional 4seq
|
||||
[ "tr" surround-with-foo ] action ;
|
||||
|
||||
MEMO: table ( -- parser )
|
||||
table-row repeat1
|
||||
[ "table" surround-with-foo ] action ;
|
||||
|
||||
MEMO: code ( -- parser )
|
||||
[
|
||||
"[" token hide ,
|
||||
[ CHAR: { = not ] satisfy repeat1 optional [ >string ] action ,
|
||||
"{" token hide ,
|
||||
"}]" token ensure-not any-char 2seq repeat0 [ concat >string ] action ,
|
||||
"}]" token hide ,
|
||||
] seq* [ first2 swap render-code ] action ;
|
||||
|
||||
MEMO: line ( -- parser )
|
||||
[
|
||||
nl table 2seq ,
|
||||
nl list 2seq ,
|
||||
text , strong , emphasis , link ,
|
||||
superscript , subscript , inline-code ,
|
||||
escaped-char , delimiter , eq ,
|
||||
] choice* repeat1 ;
|
||||
|
||||
MEMO: paragraph ( -- parser )
|
||||
line
|
||||
nl over 2seq repeat0
|
||||
nl nl ensure-not 2seq optional 3seq
|
||||
[
|
||||
dup [ dup string? not swap [ blank? ] all? or ] deep-all?
|
||||
[ "<p>" swap "</p>" 3array ] unless
|
||||
] action ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
PEG: parse-farkup ( -- parser )
|
||||
[
|
||||
list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,
|
||||
] choice* repeat0 nl optional 2seq ;
|
||||
|
||||
: write-farkup ( parse-result -- )
|
||||
[ dup string? [ write ] [ drop ] if ] deep-each ;
|
||||
GENERIC: write-farkup ( obj -- )
|
||||
: <foo.> ( string -- ) <foo> write ;
|
||||
: </foo.> ( string -- ) </foo> write ;
|
||||
: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
|
||||
M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ;
|
||||
M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ;
|
||||
M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ;
|
||||
M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ;
|
||||
M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ;
|
||||
M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ;
|
||||
M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ;
|
||||
M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ;
|
||||
M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ;
|
||||
M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ;
|
||||
M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ;
|
||||
M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ;
|
||||
M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ;
|
||||
M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
|
||||
M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
|
||||
M: table-row write-farkup ( obj -- )
|
||||
obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ;
|
||||
M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ;
|
||||
M: fixnum write-farkup ( obj -- ) write1 ;
|
||||
M: string write-farkup ( obj -- ) write ;
|
||||
M: vector write-farkup ( obj -- ) [ write-farkup ] each ;
|
||||
M: f write-farkup ( obj -- ) drop ;
|
||||
|
||||
: convert-farkup ( string -- string' )
|
||||
parse-farkup [ write-farkup ] with-string-writer ;
|
||||
farkup [ write-farkup ] with-string-writer ;
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ IN: golden-section
|
|||
: golden-section-window ( -- )
|
||||
[
|
||||
[ display ] <slate>
|
||||
{ 600 600 } over set-slate-dim
|
||||
{ 600 600 } over set-slate-pdim
|
||||
"Golden Section" open-window
|
||||
] with-ui ;
|
||||
|
||||
|
|
|
|||
|
|
@ -155,7 +155,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
|
|||
|
||||
[ ] [ "-foo\n-bar" "farkup" set-value ] unit-test
|
||||
|
||||
[ "<ul><li>foo</li><li>bar</li></ul>" ] [
|
||||
[ "<ul><li>foo</li>\n<li>bar</li></ul>" ] [
|
||||
[ "farkup" T{ farkup } render ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -2,10 +2,11 @@ USING: alien.syntax alien.c-types core-foundation system
|
|||
combinators kernel sequences debugger io accessors ;
|
||||
IN: iokit
|
||||
|
||||
<< {
|
||||
{ [ os macosx? ] [ "/System/Library/Frameworks/IOKit.framework" load-framework ] }
|
||||
[ "IOKit only supported on Mac OS X" ]
|
||||
} cond >>
|
||||
<<
|
||||
os macosx?
|
||||
[ "/System/Library/Frameworks/IOKit.framework" load-framework ]
|
||||
when
|
||||
>>
|
||||
|
||||
: kIOKitBuildVersionKey "IOKitBuildVersion" ; inline
|
||||
: kIOKitDiagnosticsKey "IOKitDiagnostics" ; inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1,17 @@
|
|||
! Copyright (C) 2008 William Schlieper
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: kernel vocabs.loader sequences strings splitting words irc.messages ;
|
||||
|
||||
IN: irc.ui.commandparser
|
||||
|
||||
"irc.ui.commands" require
|
||||
|
||||
: command ( string string -- string command )
|
||||
dup empty? [ drop "say" ] when
|
||||
dup "irc.ui.commands" lookup
|
||||
[ nip ]
|
||||
[ " " append prepend "quote" "irc.ui.commands" lookup ] if* ;
|
||||
|
||||
: parse-message ( string -- )
|
||||
"/" ?head [ " " split1 swap command ] [ "say" command ] if execute ;
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
! Copyright (C) 2008 William Schlieper
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: accessors kernel irc.client irc.messages irc.ui namespaces ;
|
||||
|
||||
IN: irc.ui.commands
|
||||
|
||||
: say ( string -- )
|
||||
[ client get profile>> nickname>> <own-message> print-irc ]
|
||||
[ listener get write-message ] bi ;
|
||||
|
||||
: quote ( string -- )
|
||||
drop ; ! THIS WILL CHANGE
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
! Default system ircui-rc file
|
||||
! Copy into .ircui-rc in your home directory and then change username and such
|
||||
! To find your home directory, type "home ." into a Factor listener
|
||||
|
||||
USING: irc.client irc.ui ;
|
||||
|
||||
"irc.freenode.org" 8001 "factor-irc" f ! server port nick password
|
||||
{ "#concatenative" "#terrorisland" } ! all the channels you want to autojoin
|
||||
server-open
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2008 William Schlieper
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: kernel io.files parser editors sequences ;
|
||||
|
||||
IN: irc.ui.load
|
||||
|
||||
: file-or ( path path -- path ) over exists? ? ;
|
||||
|
||||
: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;
|
||||
|
||||
: system-ui-rc ( -- path ) "extra/irc/ui/ircui-rc" resource-path ;
|
||||
|
||||
: ircui-rc ( -- path ) personal-ui-rc system-ui-rc file-or ;
|
||||
|
||||
: run-ircui ( -- ) ircui-rc run-file ;
|
||||
|
|
@ -3,12 +3,17 @@
|
|||
|
||||
USING: accessors kernel threads combinators concurrency.mailboxes
|
||||
sequences strings hashtables splitting fry assocs hashtables
|
||||
ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers
|
||||
ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs
|
||||
io io.styles namespaces irc.client irc.messages ;
|
||||
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
|
||||
io io.styles namespaces calendar calendar.format
|
||||
irc.client irc.client.private irc.messages irc.messages.private
|
||||
irc.ui.commandparser irc.ui.load ;
|
||||
|
||||
IN: irc.ui
|
||||
|
||||
SYMBOL: listener
|
||||
|
||||
SYMBOL: client
|
||||
|
||||
TUPLE: ui-window client tabs ;
|
||||
|
|
@ -19,36 +24,45 @@ TUPLE: ui-window client tabs ;
|
|||
: green { 0 0.5 0 1 } ;
|
||||
: blue { 0 0 1 1 } ;
|
||||
|
||||
: prefix>nick ( prefix -- nick )
|
||||
"!" split first ;
|
||||
: dot-or-parens ( string -- string )
|
||||
dup empty? [ drop "." ]
|
||||
[ "(" prepend ")" append ] if ;
|
||||
|
||||
GENERIC: write-irc ( irc-message -- )
|
||||
|
||||
M: privmsg write-irc
|
||||
"<" blue write-color
|
||||
[ prefix>> prefix>nick write ] keep
|
||||
">" blue write-color
|
||||
" " write
|
||||
[ prefix>> parse-name write ] keep
|
||||
"> " blue write-color
|
||||
trailing>> write ;
|
||||
|
||||
TUPLE: own-message message nick timestamp ;
|
||||
|
||||
: <own-message> ( message nick -- own-message )
|
||||
now own-message boa ;
|
||||
|
||||
M: own-message write-irc
|
||||
"<" blue write-color
|
||||
[ nick>> bold font-style associate format ] keep
|
||||
"> " blue write-color
|
||||
message>> write ;
|
||||
|
||||
M: join write-irc
|
||||
"* " green write-color
|
||||
prefix>> prefix>nick write
|
||||
prefix>> parse-name write
|
||||
" has entered the channel." green write-color ;
|
||||
|
||||
M: part write-irc
|
||||
"* " red write-color
|
||||
[ prefix>> prefix>nick write ] keep
|
||||
" has left the channel(" red write-color
|
||||
trailing>> write
|
||||
")" red write-color ;
|
||||
[ prefix>> parse-name write ] keep
|
||||
" has left the channel" red write-color
|
||||
trailing>> dot-or-parens red write-color ;
|
||||
|
||||
M: quit write-irc
|
||||
"* " red write-color
|
||||
[ prefix>> prefix>nick write ] keep
|
||||
" has left IRC(" red write-color
|
||||
trailing>> write
|
||||
")" red write-color ;
|
||||
[ prefix>> parse-name write ] keep
|
||||
" has left IRC" red write-color
|
||||
trailing>> dot-or-parens red write-color ;
|
||||
|
||||
M: irc-end write-irc
|
||||
drop "* You have left IRC" red write-color ;
|
||||
|
|
@ -63,15 +77,12 @@ M: irc-message write-irc
|
|||
drop ; ! catch all unimplemented writes, THIS WILL CHANGE
|
||||
|
||||
: print-irc ( irc-message -- )
|
||||
write-irc nl ;
|
||||
[ timestamp>> timestamp>hms write " " write ]
|
||||
[ write-irc nl ] bi ;
|
||||
|
||||
: send-message ( message listener client -- )
|
||||
"<" blue write-color
|
||||
profile>> nickname>> bold font-style associate format
|
||||
">" blue write-color
|
||||
" " write
|
||||
over write nl
|
||||
out-messages>> mailbox-put ;
|
||||
: send-message ( message -- )
|
||||
[ print-irc ]
|
||||
[ listener get write-message ] bi ;
|
||||
|
||||
: display ( stream listener -- )
|
||||
'[ , [ [ t ]
|
||||
|
|
@ -84,35 +95,44 @@ M: irc-message write-irc
|
|||
|
||||
TUPLE: irc-editor < editor outstream listener client ;
|
||||
|
||||
: <irc-editor> ( pane listener client -- editor )
|
||||
[ irc-editor new-editor
|
||||
: <irc-editor> ( page pane listener -- client editor )
|
||||
irc-editor new-editor
|
||||
swap >>listener swap <pane-stream> >>outstream
|
||||
] dip client>> >>client ;
|
||||
over client>> >>client ;
|
||||
|
||||
: editor-send ( irc-editor -- )
|
||||
{ [ outstream>> ]
|
||||
[ editor-string ]
|
||||
[ listener>> ]
|
||||
[ client>> ]
|
||||
[ editor-string ]
|
||||
[ "" swap set-editor-string ] } cleave
|
||||
'[ , , , send-message ] with-output-stream ;
|
||||
'[ , listener set , client set , parse-message ] with-output-stream ;
|
||||
|
||||
irc-editor "general" f {
|
||||
{ T{ key-down f f "RET" } editor-send }
|
||||
{ T{ key-down f f "ENTER" } editor-send }
|
||||
} define-command-map
|
||||
|
||||
: irc-page ( name pane editor tabbed -- )
|
||||
[ [ <scroller> @bottom frame, ! editor
|
||||
<scroller> @center frame, ! pane
|
||||
] make-frame swap ] dip add-page ;
|
||||
TUPLE: irc-page < frame listener client ;
|
||||
|
||||
: <irc-page> ( listener client -- irc-page )
|
||||
irc-page new-frame
|
||||
swap client>> >>client swap [ >>listener ] keep
|
||||
[ <irc-pane> [ <scroller> @center grid-add* ] keep ]
|
||||
[ <irc-editor> <scroller> @bottom grid-add* ] bi ;
|
||||
|
||||
M: irc-page graft*
|
||||
[ listener>> ] [ client>> ] bi
|
||||
add-listener ;
|
||||
|
||||
M: irc-page ungraft*
|
||||
[ listener>> ] [ client>> ] bi
|
||||
remove-listener ;
|
||||
|
||||
: join-channel ( name ui-window -- )
|
||||
[ dup <irc-channel-listener> ] dip
|
||||
[ client>> add-listener ]
|
||||
[ drop <irc-pane> dup ]
|
||||
[ [ <irc-editor> ] keep ] 2tri
|
||||
tabs>> irc-page ;
|
||||
[ <irc-page> swap ] keep
|
||||
tabs>> add-page ;
|
||||
|
||||
: irc-window ( ui-window -- )
|
||||
[ tabs>> ]
|
||||
|
|
@ -125,6 +145,10 @@ irc-editor "general" f {
|
|||
[ listeners>> +server-listener+ swap at <irc-pane> <scroller>
|
||||
"Server" associate <tabbed> >>tabs ] bi ;
|
||||
|
||||
: freenode-connect ( -- ui-window )
|
||||
"irc.freenode.org" 8001 "factor-irc" f
|
||||
<irc-profile> ui-connect [ irc-window ] keep ;
|
||||
: server-open ( server port nick password channels -- )
|
||||
[ <irc-profile> ui-connect [ irc-window ] keep ] dip
|
||||
[ over join-channel ] each ;
|
||||
|
||||
: main-run ( -- ) run-ircui ;
|
||||
|
||||
MAIN: main-run
|
||||
|
|
|
|||
|
|
@ -158,7 +158,9 @@ DEFER: empty-model
|
|||
: lsys-viewer ( -- )
|
||||
|
||||
[ ] <slate> >slate
|
||||
{ 400 400 } clone slate> set-slate-dim
|
||||
{ 400 400 } clone slate> set-slate-pdim
|
||||
|
||||
slate> <handler>
|
||||
|
||||
{
|
||||
|
||||
|
|
@ -194,13 +196,9 @@ DEFER: empty-model
|
|||
[ [ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
|
||||
camera-action ] }
|
||||
|
||||
! } [ make* ] map alist>hash <handler> >handler
|
||||
} [ make* ] map >hashtable >>table
|
||||
|
||||
} [ make* ] map >hashtable <handler> >handler
|
||||
|
||||
slate> handler> set-gadget-delegate
|
||||
|
||||
handler> "L-system view" open-window
|
||||
"L-system view" open-window
|
||||
|
||||
500 sleep
|
||||
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ kernel strings ;
|
|||
{ { object ppc object } "b" }
|
||||
{ { string object windows } "c" }
|
||||
}
|
||||
V{ cpu os }
|
||||
{ cpu os }
|
||||
] [
|
||||
example-1 canonicalize-specializers
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -449,7 +449,7 @@ foo=<foreign any-char> 'd'
|
|||
] unit-test
|
||||
|
||||
[
|
||||
"USING: peg.ebnf ; \"ab\" [EBNF foo='a' foo='b' EBNF]" eval drop
|
||||
"USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval drop
|
||||
] must-fail
|
||||
|
||||
{ t } [
|
||||
|
|
@ -519,4 +519,4 @@ Tok = Spaces (Number | Special )
|
|||
|
||||
{ "\\" } [
|
||||
"\\" [EBNF foo="\\" EBNF]
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -371,7 +371,7 @@ M: ebnf-tokenizer (transform) ( ast -- parser )
|
|||
M: ebnf-rule (transform) ( ast -- parser )
|
||||
dup elements>>
|
||||
(transform) [
|
||||
swap symbol>> dup get { [ tuple? ] [ delegate parser? ] } 1&& [
|
||||
swap symbol>> dup get parser? [
|
||||
"Rule '" over append "' defined more than once" append throw
|
||||
] [
|
||||
set
|
||||
|
|
|
|||
|
|
@ -0,0 +1,27 @@
|
|||
|
||||
USING: kernel words lexer parser sequences accessors self ;
|
||||
|
||||
IN: self.slots
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: define-self-slot-reader ( slot -- )
|
||||
[ "->" append current-vocab create dup set-word ]
|
||||
[ ">>" append search [ self> ] swap suffix ] bi
|
||||
(( -- value )) define-declared ;
|
||||
|
||||
: define-self-slot-writer ( slot -- )
|
||||
[ "->" prepend current-vocab create dup set-word ]
|
||||
[ ">>" prepend search [ self> swap ] swap suffix [ drop ] append ] bi
|
||||
(( value -- )) define-declared ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: define-self-slot-accessors ( class -- )
|
||||
"slots" word-prop
|
||||
[ name>> ] map
|
||||
[ [ define-self-slot-reader ] [ define-self-slot-writer ] bi ] each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: SELF-SLOTS: scan-word define-self-slot-accessors ; parsing
|
||||
|
|
@ -51,7 +51,7 @@ DEFER: maybe-loop
|
|||
: springies-window* ( -- )
|
||||
|
||||
C[ display ] <slate> >slate
|
||||
{ 800 600 } slate> set-slate-dim
|
||||
{ 800 600 } slate> set-slate-pdim
|
||||
C[ { 500 500 } >world-size loop on [ run ] in-thread ]
|
||||
slate> set-slate-graft
|
||||
C[ loop off ] slate> set-slate-ungraft
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
|
||||
USING: kernel assocs ui.gestures ;
|
||||
USING: kernel assocs ui.gestures ui.gadgets.wrappers accessors ;
|
||||
|
||||
IN: ui.gadgets.handler
|
||||
|
||||
TUPLE: handler table ;
|
||||
TUPLE: handler < wrapper table ;
|
||||
|
||||
C: <handler> handler
|
||||
: <handler> ( child -- handler ) handler new-wrapper ;
|
||||
|
||||
M: handler handle-gesture* ( gadget gesture delegate -- ? )
|
||||
handler-table at dup [ call f ] [ 2drop t ] if ;
|
||||
table>> at dup [ call f ] [ 2drop t ] if ;
|
||||
|
|
@ -1,66 +1,55 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
|
||||
ui.gadgets.labels ui.gadgets.scrollers
|
||||
ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs
|
||||
ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render
|
||||
hashtables io kernel namespaces sequences io.styles strings
|
||||
quotations math opengl combinators math.vectors
|
||||
sorting splitting io.streams.nested assocs
|
||||
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
|
||||
ui.gadgets.grid-lines classes.tuple models continuations
|
||||
destructors accessors math.geometry.rect ;
|
||||
ui.gadgets.labels ui.gadgets.scrollers
|
||||
ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs
|
||||
ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render
|
||||
hashtables io kernel namespaces sequences io.styles strings
|
||||
quotations math opengl combinators math.vectors
|
||||
sorting splitting io.streams.nested assocs
|
||||
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
|
||||
ui.gadgets.grid-lines classes.tuple models continuations
|
||||
destructors accessors math.geometry.rect ;
|
||||
|
||||
IN: ui.gadgets.panes
|
||||
|
||||
TUPLE: pane < pack
|
||||
output current prototype scrolls?
|
||||
selection-color caret mark selecting? ;
|
||||
output current prototype scrolls?
|
||||
selection-color caret mark selecting? ;
|
||||
|
||||
: clear-selection ( pane -- )
|
||||
f >>caret
|
||||
f >>mark
|
||||
drop ;
|
||||
: clear-selection ( pane -- pane ) f >>caret f >>mark ;
|
||||
|
||||
: add-output ( current pane -- )
|
||||
[ set-pane-output ] [ swap add-gadget drop ] 2bi ;
|
||||
: add-output ( pane current -- pane ) [ >>output ] [ add-gadget ] bi ;
|
||||
: add-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ;
|
||||
|
||||
: add-current ( current pane -- )
|
||||
[ set-pane-current ] [ swap add-gadget drop ] 2bi ;
|
||||
: prepare-line ( pane -- pane )
|
||||
clear-selection
|
||||
dup prototype>> clone add-current ;
|
||||
|
||||
: prepare-line ( pane -- )
|
||||
[ clear-selection ]
|
||||
[ [ pane-prototype clone ] keep add-current ] bi ;
|
||||
|
||||
: pane-caret&mark ( pane -- caret mark )
|
||||
[ caret>> ] [ mark>> ] bi ;
|
||||
: pane-caret&mark ( pane -- caret mark ) [ caret>> ] [ mark>> ] bi ;
|
||||
|
||||
: selected-children ( pane -- seq )
|
||||
[ pane-caret&mark sort-pair ] keep gadget-subtree ;
|
||||
|
||||
M: pane gadget-selection? pane-caret&mark and ;
|
||||
|
||||
M: pane gadget-selection
|
||||
selected-children gadget-text ;
|
||||
M: pane gadget-selection ( pane -- string/f ) selected-children gadget-text ;
|
||||
|
||||
: pane-clear ( pane -- )
|
||||
[ clear-selection ]
|
||||
[ pane-output clear-incremental ]
|
||||
[ pane-current clear-gadget ]
|
||||
tri ;
|
||||
|
||||
: pane-theme ( pane -- pane )
|
||||
selection-color >>selection-color ; inline
|
||||
clear-selection
|
||||
[ pane-output clear-incremental ]
|
||||
[ pane-current clear-gadget ]
|
||||
bi ;
|
||||
|
||||
: new-pane ( class -- pane )
|
||||
new-gadget
|
||||
{ 0 1 } >>orientation
|
||||
<shelf> >>prototype
|
||||
<incremental> over add-output
|
||||
dup prepare-line
|
||||
pane-theme ;
|
||||
<incremental> add-output
|
||||
prepare-line
|
||||
selection-color >>selection-color ;
|
||||
|
||||
: <pane> ( -- pane )
|
||||
pane new-pane ;
|
||||
: <pane> ( -- pane ) pane new-pane ;
|
||||
|
||||
GENERIC: draw-selection ( loc obj -- )
|
||||
|
||||
|
|
@ -102,25 +91,25 @@ C: <pane-stream> pane-stream
|
|||
|
||||
: smash-pane ( pane -- gadget ) pane-output smash-line ;
|
||||
|
||||
: pane-nl ( pane -- )
|
||||
: pane-nl ( pane -- pane )
|
||||
dup pane-current dup unparent smash-line
|
||||
over pane-output add-incremental
|
||||
prepare-line ;
|
||||
|
||||
: pane-write ( pane seq -- )
|
||||
[ dup pane-nl ]
|
||||
[ pane-nl ]
|
||||
[ over pane-current stream-write ]
|
||||
interleave drop ;
|
||||
|
||||
: pane-format ( style pane seq -- )
|
||||
[ dup pane-nl ]
|
||||
[ pane-nl ]
|
||||
[ 2over pane-current stream-format ]
|
||||
interleave 2drop ;
|
||||
|
||||
GENERIC: write-gadget ( gadget stream -- )
|
||||
|
||||
M: pane-stream write-gadget
|
||||
pane-stream-pane pane-current swap add-gadget drop ;
|
||||
M: pane-stream write-gadget ( gadget pane-stream -- )
|
||||
pane>> current>> swap add-gadget drop ;
|
||||
|
||||
M: style-stream write-gadget
|
||||
stream>> write-gadget ;
|
||||
|
|
@ -148,8 +137,8 @@ M: style-stream write-gadget
|
|||
|
||||
TUPLE: pane-control < pane quot ;
|
||||
|
||||
M: pane-control model-changed
|
||||
swap model-value swap dup pane-control-quot with-pane ;
|
||||
M: pane-control model-changed ( model pane-control -- )
|
||||
[ value>> ] [ dup quot>> ] bi* with-pane ;
|
||||
|
||||
: <pane-control> ( model quot -- pane )
|
||||
pane-control new-pane
|
||||
|
|
@ -160,7 +149,7 @@ M: pane-control model-changed
|
|||
>r pane-stream-pane r> keep scroll-pane ; inline
|
||||
|
||||
M: pane-stream stream-nl
|
||||
[ pane-nl ] do-pane-stream ;
|
||||
[ pane-nl drop ] do-pane-stream ;
|
||||
|
||||
M: pane-stream stream-write1
|
||||
[ pane-current stream-write1 ] do-pane-stream ;
|
||||
|
|
@ -337,15 +326,14 @@ M: paragraph stream-format
|
|||
2drop
|
||||
] if ;
|
||||
|
||||
: caret>mark ( pane -- )
|
||||
dup pane-caret over set-pane-mark relayout-1 ;
|
||||
: caret>mark ( pane -- pane )
|
||||
dup caret>> >>mark
|
||||
dup relayout-1 ;
|
||||
|
||||
GENERIC: sloppy-pick-up* ( loc gadget -- n )
|
||||
|
||||
M: pack sloppy-pick-up*
|
||||
dup gadget-orientation
|
||||
swap gadget-children
|
||||
(fast-children-on) ;
|
||||
M: pack sloppy-pick-up* ( loc gadget -- n )
|
||||
[ orientation>> ] [ children>> ] bi (fast-children-on) ;
|
||||
|
||||
M: gadget sloppy-pick-up*
|
||||
gadget-children [ inside? ] with find-last drop ;
|
||||
|
|
@ -362,25 +350,25 @@ M: f sloppy-pick-up*
|
|||
[ 3drop { } ]
|
||||
if ;
|
||||
|
||||
: move-caret ( pane -- )
|
||||
dup hand-rel
|
||||
over sloppy-pick-up
|
||||
over set-pane-caret
|
||||
relayout-1 ;
|
||||
: move-caret ( pane -- pane )
|
||||
dup hand-rel
|
||||
over sloppy-pick-up
|
||||
over set-pane-caret
|
||||
dup relayout-1 ;
|
||||
|
||||
: begin-selection ( pane -- )
|
||||
dup move-caret f swap set-pane-mark ;
|
||||
move-caret f swap set-pane-mark ;
|
||||
|
||||
: extend-selection ( pane -- )
|
||||
hand-moved? [
|
||||
dup selecting?>> [
|
||||
dup move-caret
|
||||
move-caret
|
||||
] [
|
||||
dup hand-clicked get child? [
|
||||
t >>selecting?
|
||||
dup hand-clicked set-global
|
||||
dup move-caret
|
||||
dup caret>mark
|
||||
move-caret
|
||||
caret>mark
|
||||
] when
|
||||
] if
|
||||
dup dup pane-caret gadget-at-path scroll>gadget
|
||||
|
|
@ -395,8 +383,8 @@ M: f sloppy-pick-up*
|
|||
] if ;
|
||||
|
||||
: select-to-caret ( pane -- )
|
||||
dup pane-mark [ dup caret>mark ] unless
|
||||
dup move-caret
|
||||
dup pane-mark [ caret>mark ] unless
|
||||
move-caret
|
||||
dup request-focus
|
||||
com-copy-selection ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,122 +1,21 @@
|
|||
|
||||
USING: kernel namespaces opengl ui.render ui.gadgets ;
|
||||
USING: kernel namespaces opengl ui.render ui.gadgets accessors ;
|
||||
|
||||
IN: ui.gadgets.slate
|
||||
|
||||
TUPLE: slate action dim graft ungraft
|
||||
button-down
|
||||
button-up
|
||||
key-down
|
||||
key-up ;
|
||||
TUPLE: slate < gadget action pdim graft ungraft ;
|
||||
|
||||
: <slate> ( action -- slate )
|
||||
slate construct-gadget
|
||||
tuck set-slate-action
|
||||
{ 100 100 } over set-slate-dim
|
||||
[ ] over set-slate-graft
|
||||
[ ] over set-slate-ungraft ;
|
||||
slate new-gadget
|
||||
swap >>action
|
||||
{ 100 100 } >>pdim
|
||||
[ ] >>graft
|
||||
[ ] >>ungraft ;
|
||||
|
||||
M: slate pref-dim* ( slate -- dim ) slate-dim ;
|
||||
M: slate pref-dim* ( slate -- dim ) pdim>> ;
|
||||
|
||||
M: slate draw-gadget* ( slate -- )
|
||||
origin get swap slate-action with-translation ;
|
||||
M: slate draw-gadget* ( slate -- ) origin get swap action>> with-translation ;
|
||||
|
||||
M: slate graft* ( slate -- ) slate-graft call ;
|
||||
M: slate graft* ( slate -- ) graft>> call ;
|
||||
M: slate ungraft* ( slate -- ) ungraft>> call ;
|
||||
|
||||
M: slate ungraft* ( slate -- ) slate-ungraft call ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: key-pressed-value
|
||||
|
||||
: key-pressed? ( -- ? ) key-pressed-value get ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: mouse-pressed-value
|
||||
|
||||
: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: key-value
|
||||
|
||||
: key ( -- key ) key-value get ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: button-value
|
||||
|
||||
: button ( -- val ) button-value get ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
USING: combinators ui.gestures accessors ;
|
||||
|
||||
! M: slate handle-gesture* ( gadget gesture delegate -- ? )
|
||||
! drop nip
|
||||
! {
|
||||
! {
|
||||
! [ dup key-down? ]
|
||||
! [
|
||||
|
||||
! key-down-sym key-value set
|
||||
! key-pressed-value on
|
||||
! t
|
||||
! ]
|
||||
! }
|
||||
! { [ dup key-up? ] [ drop key-pressed-value off t ] }
|
||||
! {
|
||||
! [ dup button-down? ]
|
||||
! [
|
||||
! button-down-# mouse-button-value set
|
||||
! mouse-pressed-value on
|
||||
! t
|
||||
! ]
|
||||
! }
|
||||
! { [ dup button-up? ] [ drop mouse-pressed-value off t ] }
|
||||
! { [ t ] [ drop t ] }
|
||||
! }
|
||||
! cond ;
|
||||
|
||||
M: slate handle-gesture* ( gadget gesture delegate -- ? )
|
||||
rot drop swap ! delegate gesture
|
||||
{
|
||||
{
|
||||
[ dup key-down? ]
|
||||
[
|
||||
key-down-sym key-value set
|
||||
key-pressed-value on
|
||||
key-down>> dup [ call ] [ drop ] if
|
||||
t
|
||||
]
|
||||
}
|
||||
{
|
||||
[ dup key-up? ]
|
||||
[
|
||||
key-pressed-value off
|
||||
drop
|
||||
key-up>> dup [ call ] [ drop ] if
|
||||
t
|
||||
] }
|
||||
{
|
||||
[ dup button-down? ]
|
||||
[
|
||||
button-down-# button-value set
|
||||
mouse-pressed-value on
|
||||
button-down>> dup [ call ] [ drop ] if
|
||||
t
|
||||
]
|
||||
}
|
||||
{
|
||||
[ dup button-up? ]
|
||||
[
|
||||
mouse-pressed-value off
|
||||
drop
|
||||
button-up>> dup [ call ] [ drop ] if
|
||||
t
|
||||
]
|
||||
}
|
||||
{ [ t ] [ 2drop t ] }
|
||||
}
|
||||
cond ;
|
||||
|
|
@ -1,22 +1,18 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors ui.gadgets kernel ;
|
||||
|
||||
IN: ui.gadgets.wrappers
|
||||
|
||||
TUPLE: wrapper < gadget ;
|
||||
|
||||
: new-wrapper ( child class -- wrapper )
|
||||
new-gadget
|
||||
[ swap add-gadget drop ] keep ; inline
|
||||
: new-wrapper ( child class -- wrapper ) new-gadget swap add-gadget ;
|
||||
|
||||
: <wrapper> ( child -- border )
|
||||
wrapper new-wrapper ;
|
||||
: <wrapper> ( child -- border ) wrapper new-wrapper ;
|
||||
|
||||
M: wrapper pref-dim*
|
||||
gadget-child pref-dim ;
|
||||
M: wrapper pref-dim* ( wrapper -- dim ) gadget-child pref-dim ;
|
||||
|
||||
M: wrapper layout*
|
||||
M: wrapper layout* ( wrapper -- )
|
||||
[ dim>> ] [ gadget-child ] bi set-layout-dim ;
|
||||
|
||||
M: wrapper focusable-child*
|
||||
gadget-child ;
|
||||
M: wrapper focusable-child* ( wrapper -- child/t ) gadget-child ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.files io.encodings.ascii sequences generalizations
|
||||
math.parser combinators kernel memoize csv symbols summary
|
||||
words accessors math.order sorting ;
|
||||
words accessors math.order binary-search ;
|
||||
IN: usa-cities
|
||||
|
||||
SINGLETONS: AK AL AR AS AZ CA CO CT DC DE FL GA HI IA ID IL IN
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax io kernel math quotations
|
||||
multiline ;
|
||||
multiline destructors ;
|
||||
IN: windows.com
|
||||
|
||||
HELP: com-query-interface
|
||||
|
|
@ -13,3 +13,14 @@ HELP: com-add-ref
|
|||
HELP: com-release
|
||||
{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }
|
||||
{ $description "A small wrapper around " { $link IUnknown::Release } ". Decrements the reference count on " { $snippet "interface" } ", releasing the underlying object if the reference count has reached zero." } ;
|
||||
|
||||
HELP: &com-release
|
||||
{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }
|
||||
{ $description "Marks the given COM interface for unconditional release via " { $link com-release } " at the end of the enclosing " { $link with-destructors } " scope." } ;
|
||||
|
||||
HELP: |com-release
|
||||
{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }
|
||||
{ $description "Marks the given COM interface for release via " { $link com-release } " in the event of an error at the end of the enclosing " { $link with-destructors } " scope." } ;
|
||||
|
||||
{ com-release &com-release |com-release } related-words
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
USING: alien alien.c-types windows.com.syntax windows.ole32
|
||||
windows.types continuations kernel alien.syntax libc ;
|
||||
windows.types continuations kernel alien.syntax libc
|
||||
destructors accessors ;
|
||||
IN: windows.com
|
||||
|
||||
LIBRARY: ole32
|
||||
|
|
@ -39,3 +40,11 @@ COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}
|
|||
|
||||
: with-com-interface ( interface quot -- )
|
||||
over [ slip ] [ com-release ] [ ] cleanup ; inline
|
||||
|
||||
TUPLE: com-destructor interface disposed ;
|
||||
M: com-destructor dispose* interface>> com-release ;
|
||||
|
||||
: &com-release ( interface -- interface )
|
||||
dup f com-destructor boa &dispose drop ;
|
||||
: |com-release ( interface -- interface )
|
||||
dup f com-destructor boa |dispose drop ;
|
||||
|
|
|
|||
|
|
@ -2,9 +2,10 @@ USING: windows.kernel32 windows.ole32 windows.com windows.com.syntax
|
|||
alien alien.c-types alien.syntax kernel system namespaces math ;
|
||||
IN: windows.dinput
|
||||
|
||||
<< os windows?
|
||||
<<
|
||||
os windows?
|
||||
[ "dinput" "dinput8.dll" "stdcall" add-library ]
|
||||
[ "DirectInput only supported on Windows" throw ] if
|
||||
when
|
||||
>>
|
||||
|
||||
LIBRARY: dinput
|
||||
|
|
|
|||
Loading…
Reference in New Issue