\ + 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
! Regression
USE: sorting
-USE: sorting.private
+USE: binary-search.private
: old-binsearch ( elt quot seq -- elt quot i )
dup length 1 <= [
] [
[ 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 ] [
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:"
] 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
{ 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
: 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
ui
ui.gestures
ui.gadgets
- ui.gadgets.handler
ui.gadgets.slate
ui.gadgets.labels
ui.gadgets.buttons
ui.gadgets.packs
ui.gadgets.grids
ui.gadgets.theme
+ ui.gadgets.handler
accessors
qualified
namespaces.lib assocs.lib vars
@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
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 ;
--- /dev/null
+! 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
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
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
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 ;
: 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 ;
\ No newline at end of file
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
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
-USING: alien strings arrays help.markup help.syntax ;
+USING: alien strings arrays help.markup help.syntax destructors ;
IN: core-foundation
HELP: CF>array
{ $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
{ $subsection <CFFileSystemURL> }
{ $subsection <CFURL> }
"Frameworks:"
-{ $subsection load-framework } ;
+{ $subsection load-framework }
+"Memory management:"
+{ $subsection &CFRelease }
+{ $subsection |CFRelease } ;
-IN: core-foundation
ABOUT: "core-foundation"
! 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
"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
--- /dev/null
+
+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 ;
+
+++ /dev/null
-Doug Coleman
-Slava Pestov
Doug Coleman
+Slava Pestov
-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
+
+[ ] [
+ "abcd-*strong*\nasdifj\nweouh23ouh23\n"
+ "paragraph" \ farkup rule parse drop
+] unit-test
-[ "<ul><li>foo</li></ul>\n<p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] 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
[ "<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
[ "\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
] [ "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
! 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 ]]
+
+heading4 = "====" (!("=" | nl).)+ "===="
+ => [[ second >string heading4 boa ]]
+
+strong = "*" (!("*" | nl).)+ "*"
+ => [[ second >string strong boa ]]
+
+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
-: delimited ( str html -- parser )
- [
- over token hide ,
- text [ surround-with-foo ] swapd curry action ,
- token hide ,
- ] seq* ;
-
-MEMO: escaped-char ( -- parser )
- [ "\\" token hide , any-char , ] seq* [ >string ] action ;
-
-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 ;
-
-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');" ;
: 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 )
- [
- "[[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 ;
-
-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 )
+: render-code ( string mode -- string' )
+ >r string-lines r>
[
- 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 ;
+ <pre>
+ htmlize-lines
+ </pre>
+ ] with-string-writer write ;
+
+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 ;
: golden-section-window ( -- )
[
[ display ] <slate>
- { 600 600 } over set-slate-dim
+ { 600 600 } over set-slate-pdim
"Golden Section" open-window
] with-ui ;
[ ] [ "-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
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
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: kernel vocabs.loader sequences strings splitting words irc.messages ;\r
+\r
+IN: irc.ui.commandparser\r
+\r
+"irc.ui.commands" require\r
+\r
+: command ( string string -- string command )\r
+ dup empty? [ drop "say" ] when\r
+ dup "irc.ui.commands" lookup\r
+ [ nip ]\r
+ [ " " append prepend "quote" "irc.ui.commands" lookup ] if* ;\r
+\r
+: parse-message ( string -- )\r
+ "/" ?head [ " " split1 swap command ] [ "say" command ] if execute ;\r
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: accessors kernel irc.client irc.messages irc.ui namespaces ;\r
+\r
+IN: irc.ui.commands\r
+\r
+: say ( string -- )\r
+ [ client get profile>> nickname>> <own-message> print-irc ]\r
+ [ listener get write-message ] bi ;\r
+\r
+: quote ( string -- )\r
+ drop ; ! THIS WILL CHANGE\r
--- /dev/null
+! Default system ircui-rc file\r
+! Copy into .ircui-rc in your home directory and then change username and such\r
+! To find your home directory, type "home ." into a Factor listener\r
+\r
+USING: irc.client irc.ui ;\r
+\r
+"irc.freenode.org" 8001 "factor-irc" f ! server port nick password\r
+{ "#concatenative" "#terrorisland" } ! all the channels you want to autojoin\r
+server-open\r
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: kernel io.files parser editors sequences ;\r
+\r
+IN: irc.ui.load\r
+\r
+: file-or ( path path -- path ) over exists? ? ;\r
+\r
+: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;\r
+\r
+: system-ui-rc ( -- path ) "extra/irc/ui/ircui-rc" resource-path ;\r
+\r
+: ircui-rc ( -- path ) personal-ui-rc system-ui-rc file-or ;\r
+\r
+: run-ircui ( -- ) ircui-rc run-file ;\r
\r
USING: accessors kernel threads combinators concurrency.mailboxes\r
sequences strings hashtables splitting fry assocs hashtables\r
- ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers\r
- ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs\r
- io io.styles namespaces irc.client irc.messages ;\r
+ ui ui.gadgets ui.gadgets.panes ui.gadgets.editors\r
+ ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures\r
+ ui.gadgets.tabs ui.gadgets.grids\r
+ io io.styles namespaces calendar calendar.format\r
+ irc.client irc.client.private irc.messages irc.messages.private\r
+ irc.ui.commandparser irc.ui.load ;\r
\r
IN: irc.ui\r
\r
+SYMBOL: listener\r
+\r
SYMBOL: client\r
\r
TUPLE: ui-window client tabs ;\r
: green { 0 0.5 0 1 } ;\r
: blue { 0 0 1 1 } ;\r
\r
-: prefix>nick ( prefix -- nick )\r
- "!" split first ;\r
+: dot-or-parens ( string -- string )\r
+ dup empty? [ drop "." ]\r
+ [ "(" prepend ")" append ] if ;\r
\r
GENERIC: write-irc ( irc-message -- )\r
\r
M: privmsg write-irc\r
"<" blue write-color\r
- [ prefix>> prefix>nick write ] keep\r
- ">" blue write-color\r
- " " write\r
+ [ prefix>> parse-name write ] keep\r
+ "> " blue write-color\r
trailing>> write ;\r
\r
+TUPLE: own-message message nick timestamp ;\r
+\r
+: <own-message> ( message nick -- own-message )\r
+ now own-message boa ;\r
+\r
+M: own-message write-irc\r
+ "<" blue write-color\r
+ [ nick>> bold font-style associate format ] keep\r
+ "> " blue write-color\r
+ message>> write ;\r
+\r
M: join write-irc\r
"* " green write-color\r
- prefix>> prefix>nick write\r
+ prefix>> parse-name write\r
" has entered the channel." green write-color ;\r
\r
M: part write-irc\r
"* " red write-color\r
- [ prefix>> prefix>nick write ] keep\r
- " has left the channel(" red write-color\r
- trailing>> write\r
- ")" red write-color ;\r
+ [ prefix>> parse-name write ] keep\r
+ " has left the channel" red write-color\r
+ trailing>> dot-or-parens red write-color ;\r
\r
M: quit write-irc\r
"* " red write-color\r
- [ prefix>> prefix>nick write ] keep\r
- " has left IRC(" red write-color\r
- trailing>> write\r
- ")" red write-color ;\r
+ [ prefix>> parse-name write ] keep\r
+ " has left IRC" red write-color\r
+ trailing>> dot-or-parens red write-color ;\r
\r
M: irc-end write-irc\r
drop "* You have left IRC" red write-color ;\r
drop ; ! catch all unimplemented writes, THIS WILL CHANGE \r
\r
: print-irc ( irc-message -- )\r
- write-irc nl ;\r
+ [ timestamp>> timestamp>hms write " " write ]\r
+ [ write-irc nl ] bi ;\r
\r
-: send-message ( message listener client -- )\r
- "<" blue write-color\r
- profile>> nickname>> bold font-style associate format\r
- ">" blue write-color\r
- " " write\r
- over write nl\r
- out-messages>> mailbox-put ;\r
+: send-message ( message -- )\r
+ [ print-irc ]\r
+ [ listener get write-message ] bi ;\r
\r
: display ( stream listener -- )\r
'[ , [ [ t ]\r
\r
TUPLE: irc-editor < editor outstream listener client ;\r
\r
-: <irc-editor> ( pane listener client -- editor )\r
- [ irc-editor new-editor\r
+: <irc-editor> ( page pane listener -- client editor )\r
+ irc-editor new-editor\r
swap >>listener swap <pane-stream> >>outstream\r
- ] dip client>> >>client ;\r
+ over client>> >>client ;\r
\r
: editor-send ( irc-editor -- )\r
{ [ outstream>> ]\r
- [ editor-string ]\r
[ listener>> ]\r
[ client>> ]\r
+ [ editor-string ]\r
[ "" swap set-editor-string ] } cleave\r
- '[ , , , send-message ] with-output-stream ;\r
+ '[ , listener set , client set , parse-message ] with-output-stream ;\r
\r
irc-editor "general" f {\r
{ T{ key-down f f "RET" } editor-send }\r
{ T{ key-down f f "ENTER" } editor-send }\r
} define-command-map\r
\r
-: irc-page ( name pane editor tabbed -- )\r
- [ [ <scroller> @bottom frame, ! editor\r
- <scroller> @center frame, ! pane\r
- ] make-frame swap ] dip add-page ;\r
+TUPLE: irc-page < frame listener client ;\r
+\r
+: <irc-page> ( listener client -- irc-page )\r
+ irc-page new-frame\r
+ swap client>> >>client swap [ >>listener ] keep\r
+ [ <irc-pane> [ <scroller> @center grid-add* ] keep ]\r
+ [ <irc-editor> <scroller> @bottom grid-add* ] bi ;\r
+\r
+M: irc-page graft*\r
+ [ listener>> ] [ client>> ] bi\r
+ add-listener ;\r
+\r
+M: irc-page ungraft*\r
+ [ listener>> ] [ client>> ] bi\r
+ remove-listener ;\r
\r
: join-channel ( name ui-window -- )\r
[ dup <irc-channel-listener> ] dip\r
- [ client>> add-listener ]\r
- [ drop <irc-pane> dup ]\r
- [ [ <irc-editor> ] keep ] 2tri\r
- tabs>> irc-page ;\r
+ [ <irc-page> swap ] keep\r
+ tabs>> add-page ;\r
\r
: irc-window ( ui-window -- )\r
[ tabs>> ]\r
[ listeners>> +server-listener+ swap at <irc-pane> <scroller>\r
"Server" associate <tabbed> >>tabs ] bi ;\r
\r
-: freenode-connect ( -- ui-window )\r
- "irc.freenode.org" 8001 "factor-irc" f\r
- <irc-profile> ui-connect [ irc-window ] keep ;\r
+: server-open ( server port nick password channels -- )\r
+ [ <irc-profile> ui-connect [ irc-window ] keep ] dip\r
+ [ over join-channel ] each ;\r
+\r
+: main-run ( -- ) run-ircui ;\r
+\r
+MAIN: main-run\r
: lsys-viewer ( -- )
[ ] <slate> >slate
-{ 400 400 } clone slate> set-slate-dim
+{ 400 400 } clone slate> set-slate-pdim
+
+slate> <handler>
{
[ [ 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 <handler> >handler
-
-slate> handler> set-gadget-delegate
+} [ make* ] map >hashtable >>table
-handler> "L-system view" open-window
+"L-system view" open-window
500 sleep
{ { object ppc object } "b" }
{ { string object windows } "c" }
}
- V{ cpu os }
+ { cpu os }
] [
example-1 canonicalize-specializers
] unit-test
] 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 } [
{ "\\" } [
"\\" [EBNF foo="\\" EBNF]
-] unit-test
\ No newline at end of file
+] unit-test
M: ebnf-rule (transform) ( ast -- parser )\r
dup elements>> \r
(transform) [\r
- swap symbol>> dup get { [ tuple? ] [ delegate parser? ] } 1&& [ \r
+ swap symbol>> dup get parser? [ \r
"Rule '" over append "' defined more than once" append throw \r
] [ \r
set \r
--- /dev/null
+
+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
\ No newline at end of file
: 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
-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 ;
\ No newline at end of file
+ table>> at dup [ call f ] [ 2drop t ] if ;
\ No newline at end of file
! 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? ;
-
-: clear-selection ( pane -- )
- f >>caret
- f >>mark
- drop ;
+ output current prototype scrolls?
+ selection-color caret mark selecting? ;
-: add-output ( current pane -- )
- [ set-pane-output ] [ swap add-gadget drop ] 2bi ;
+: clear-selection ( pane -- pane ) f >>caret f >>mark ;
-: add-current ( current pane -- )
- [ set-pane-current ] [ swap add-gadget drop ] 2bi ;
+: add-output ( pane current -- pane ) [ >>output ] [ add-gadget ] bi ;
+: add-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ;
-: prepare-line ( pane -- )
- [ clear-selection ]
- [ [ pane-prototype clone ] keep add-current ] bi ;
+: prepare-line ( pane -- pane )
+ clear-selection
+ dup prototype>> clone add-current ;
-: 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 -- )
: 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 ;
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
>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 ;
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 ;
[ 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
] 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 ;
-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 ;
\ No newline at end of file
! 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 ;
! 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
USING: help.markup help.syntax io kernel math quotations\r
-multiline ;\r
+multiline destructors ;\r
IN: windows.com\r
\r
HELP: com-query-interface\r
HELP: com-release\r
{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }\r
{ $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." } ;\r
+\r
+HELP: &com-release\r
+{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }\r
+{ $description "Marks the given COM interface for unconditional release via " { $link com-release } " at the end of the enclosing " { $link with-destructors } " scope." } ;\r
+\r
+HELP: |com-release\r
+{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }\r
+{ $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." } ;\r
+\r
+{ com-release &com-release |com-release } related-words\r
+\r
USING: alien alien.c-types windows.com.syntax windows.ole32\r
-windows.types continuations kernel alien.syntax libc ;\r
+windows.types continuations kernel alien.syntax libc\r
+destructors accessors ;\r
IN: windows.com\r
\r
LIBRARY: ole32\r
\r
: with-com-interface ( interface quot -- )\r
over [ slip ] [ com-release ] [ ] cleanup ; inline\r
+\r
+TUPLE: com-destructor interface disposed ;\r
+M: com-destructor dispose* interface>> com-release ;\r
+\r
+: &com-release ( interface -- interface )\r
+ dup f com-destructor boa &dispose drop ;\r
+: |com-release ( interface -- interface )\r
+ dup f com-destructor boa |dispose drop ;\r
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
projects / factor.git / commitdiff