USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc alien.strings io.encodings.utf8 ;
+\ expand-constants must-infer
+
+: xyz 123 ;
+
+[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
+
: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
[ 123 ] [ foo ] unit-test
namespaces parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary
-accessors combinators effects ;
+accessors combinators effects continuations ;
IN: alien.c-types
DEFER: <int>
} 2cleave ;
: expand-constants ( c-type -- c-type' )
- #! We use def>> call instead of execute to get around
- #! staging violations
dup array? [
- unclip >r [ dup word? [ def>> call ] when ] map r> prefix
+ unclip >r [
+ dup word? [
+ def>> { } swap with-datastack first
+ ] when
+ ] map r> prefix
] when ;
: malloc-file-contents ( path -- alien len )
binary file-contents dup malloc-byte-array swap length ;
+: if-void ( type true false -- )
+ pick "void" = [ drop nip call ] [ nip call ] if ; inline
+
[
<c-type>
[ alien-cell ] >>getter
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2003, 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel combinators sequences arrays classes.tuple accessors colors.hsv ;
+
+IN: colors
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: color ;
+
+TUPLE: rgba < color red green blue alpha ;
+
+TUPLE: hsva < color hue saturation value alpha ;
+
+TUPLE: gray < color gray alpha ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: >rgba ( object -- rgba )
+
+M: rgba >rgba ( rgba -- rgba ) ;
+
+M: hsva >rgba ( hsva -- rgba )
+ { [ hue>> ] [ saturation>> ] [ value>> ] [ alpha>> ] } cleave 4array
+ [ hsv>rgb ] [ peek ] bi suffix first4 rgba boa ;
+
+M: gray >rgba ( gray -- rgba ) [ gray>> dup dup ] [ alpha>> ] bi rgba boa ;
+
+M: color red>> ( color -- red ) >rgba red>> ;
+M: color green>> ( color -- green ) >rgba green>> ;
+M: color blue>> ( color -- blue ) >rgba blue>> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: black T{ rgba f 0.0 0.0 0.0 1.0 } ;
+: blue T{ rgba f 0.0 0.0 1.0 1.0 } ;
+: cyan T{ rgba f 0 0.941 0.941 1 } ;
+: gray T{ rgba f 0.6 0.6 0.6 1.0 } ;
+: green T{ rgba f 0.0 1.0 0.0 1.0 } ;
+: light-gray T{ rgba f 0.95 0.95 0.95 0.95 } ;
+: light-purple T{ rgba f 0.8 0.8 1.0 1.0 } ;
+: magenta T{ rgba f 0.941 0 0.941 1 } ;
+: orange T{ rgba f 0.941 0.627 0 1 } ;
+: purple T{ rgba f 0.627 0 0.941 1 } ;
+: red T{ rgba f 1.0 0.0 0.0 1.0 } ;
+: white T{ rgba f 1.0 1.0 1.0 1.0 } ;
+: yellow T{ rgba f 1.0 1.0 0.0 1.0 } ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2007 Eduardo Cavazos
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel combinators arrays sequences math math.functions ;
+
+IN: colors.hsv
+
+<PRIVATE
+
+: H ( hsv -- H ) first ;
+
+: S ( hsv -- S ) second ;
+
+: V ( hsv -- V ) third ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: Hi ( hsv -- Hi ) H 60 / floor 6 mod ;
+
+: f ( hsv -- f ) [ H 60 / ] [ Hi ] bi - ;
+
+: p ( hsv -- p ) [ S 1 swap - ] [ V ] bi * ;
+
+: q ( hsv -- q ) [ [ f ] [ S ] bi * 1 swap - ] [ V ] bi * ;
+
+: t ( hsv -- t ) [ [ f 1 swap - ] [ S ] bi * 1 swap - ] [ V ] bi * ;
+
+PRIVATE>
+
+! h [0,360)
+! s [0,1]
+! v [0,1]
+
+: hsv>rgb ( hsv -- rgb )
+dup Hi
+{ { 0 [ [ V ] [ t ] [ p ] tri ] }
+ { 1 [ [ q ] [ V ] [ p ] tri ] }
+ { 2 [ [ p ] [ V ] [ t ] tri ] }
+ { 3 [ [ p ] [ q ] [ V ] tri ] }
+ { 4 [ [ t ] [ p ] [ V ] tri ] }
+ { 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ;
: add-atoms ( seq disjoint-set -- ) '[ , add-atom ] each ;
+GENERIC: disjoint-set-member? ( a disjoint-set -- ? )
+
+M: disjoint-set disjoint-set-member? parents>> key? ;
+
GENERIC: equiv-set-size ( a disjoint-set -- n )
M: disjoint-set equiv-set-size [ representative ] keep count ;
disjoint-set link-sets
] if ;
+: equate-all-with ( seq a disjoint-set -- )
+ '[ , , equate ] each ;
+
+: equate-all ( seq disjoint-set -- )
+ over dup empty? [ 2drop ] [
+ [ unclip-slice ] dip equate-all-with
+ ] if ;
+
M: disjoint-set clone
[ parents>> ] [ ranks>> ] [ counts>> ] tri [ clone ] tri@
disjoint-set boa ;
USING: accessors sequences parser kernel help help.markup
help.topics words strings classes tools.vocabs namespaces io
io.streams.string prettyprint definitions arrays vectors
-combinators splitting debugger hashtables sorting effects vocabs
-vocabs.loader assocs editors continuations classes.predicate
-macros math sets eval ;
+combinators combinators.short-circuit splitting debugger
+hashtables sorting effects vocabs vocabs.loader assocs editors
+continuations classes.predicate macros math sets eval ;
IN: help.lint
: check-example ( element -- )
: check-values ( word element -- )
{
- { [ over "declared-effect" word-prop ] [ 2drop ] }
- { [ dup contains-funky-elements? not ] [ 2drop ] }
- { [ over macro? not ] [ 2drop ] }
+ [ drop "declared-effect" word-prop not ]
+ [ nip contains-funky-elements? ]
+ [ drop macro? ]
[
[ effect-values >array ]
[ extract-values >array ]
- bi* assert=
+ bi* =
]
- } cond ;
+ } 2|| [ "$values don't match stack effect" throw ] unless ;
: check-see-also ( word element -- )
nip \ $see-also swap elements [
byte-vectors system io.encodings math.order io.backend
continuations debugger classes byte-arrays namespaces splitting
grouping dlists assocs io.encodings.binary summary accessors
-destructors ;
+destructors combinators ;
IN: io.ports
SYMBOL: default-buffer-size
M: output-port dispose*
[
- [ handle>> &dispose drop ]
- [ port-flush ]
- [ handle>> shutdown ]
- tri
+ {
+ [ handle>> &dispose drop ]
+ [ buffer>> &dispose drop ]
+ [ port-flush ]
+ [ handle>> shutdown ]
+ } cleave
] with-destructors ;
M: buffered-port dispose*
-! Copyright (C) 2004, 2005 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USE: math
IN: math.constants
: e ( -- e ) 2.7182818284590452354 ; inline
: phi ( -- phi ) 1.61803398874989484820 ; inline
: pi ( -- pi ) 3.14159265358979323846 ; inline
: epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
+: smallest-float ( -- x ) HEX: 1 bits>double ; foldable
+: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup arrays sequences ;
IN: math.ranges
ARTICLE: "ranges" "Ranges"
-
- "A " { $emphasis "range" } " is a virtual sequence with real elements "
- "ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "."
-
- $nl
-
- "Creating ranges:"
-
- { $subsection <range> }
- { $subsection [a,b] }
- { $subsection (a,b] }
- { $subsection [a,b) }
- { $subsection (a,b) }
- { $subsection [0,b] }
- { $subsection [1,b] }
- { $subsection [0,b) } ;
\ No newline at end of file
+"A " { $emphasis "range" } " is a virtual sequence with real number elements "
+"ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "."
+$nl
+"The class of ranges:"
+{ $subsection range }
+"Creating ranges with integer end-points. The standard mathematical convention is used, where " { $snippet "(" } " or " { $snippet ")" } " denotes that the end-point itself " { $emphasis "is not" } " part of the range; " { $snippet "[" } " or " { $snippet "]" } " denotes that the end-point " { $emphasis "is" } " part of the range:"
+{ $subsection [a,b] }
+{ $subsection (a,b] }
+{ $subsection [a,b) }
+{ $subsection (a,b) }
+{ $subsection [0,b] }
+{ $subsection [1,b] }
+{ $subsection [0,b) }
+"Creating general ranges:"
+{ $subsection <range> }
+"Ranges are most frequently used with sequence combinators as a means of iterating over integers. For example,"
+{ $code
+ "3 10 [a,b] [ sqrt ] map"
+}
+"A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ;
+
+ABOUT: "ranges"
\ No newline at end of file
line-limit? [ drop t ] [ call-next-method ] if ;
: pprint-sections ( block advancer -- )
- swap sections>> [ line-break? not ] filter
- unclip pprint-section [
- dup rot call pprint-section
- ] with each ; inline
+ [
+ sections>> [ line-break? not ] filter
+ unclip-slice pprint-section
+ ] dip
+ [ [ pprint-section ] bi ] curry each ; inline
M: block short-section ( block -- )
[ advance ] pprint-sections ;
assocs sorting ;
IN: smtp.tests
-[ t ] [
- <email>
- dup clone "a" "b" set-header drop
- headers>> assoc-empty?
-] unit-test
-
{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as
[ "hello\nworld" validate-address ] must-fail
"Ed <dharmatech@factorcode.org>"
} >>to
"Doug <erg@factorcode.org>" >>from
- prepare
- dup headers>> >alist sort-keys [
- drop { "Date" "Message-Id" } member? not
- ] assoc-filter
- over to>>
- rot from>>
+ [
+ email>headers sort-keys [
+ drop { "Date" "Message-Id" } member? not
+ ] assoc-filter
+ ]
+ [ to>> [ extract-email ] map ]
+ [ from>> extract-email ] tri
] unit-test
[ ] [ [ 4321 mock-smtp-server ] "SMTP server" spawn drop ] unit-test
! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces io io.timeouts kernel logging io.sockets
+USING: arrays namespaces io io.timeouts kernel logging io.sockets
sequences combinators sequences.lib splitting assocs strings
-math.parser random system calendar io.encodings.ascii
-calendar.format accessors sets ;
+math.parser random system calendar io.encodings.ascii summary
+calendar.format accessors sets hashtables ;
IN: smtp
SYMBOL: smtp-domain
call
] with-client ; inline
+TUPLE: email
+ { from string }
+ { to array }
+ { cc array }
+ { bcc array }
+ { subject string }
+ { body string } ;
+
+: <email> ( -- email ) email new ;
+
: crlf ( -- ) "\r\n" write ;
: command ( string -- ) write crlf flush ;
: helo ( -- )
esmtp get "EHLO " "HELO " ? host-name append command ;
+ERROR: bad-email-address email ;
+
: validate-address ( string -- string' )
#! Make sure we send funky stuff to the server by accident.
dup "\r\n>" intersect empty?
- [ "Bad e-mail address: " prepend throw ] unless ;
+ [ bad-email-address ] unless ;
: mail-from ( fromaddr -- )
"MAIL FROM:<" swap validate-address ">" 3append command ;
: data ( -- )
"DATA" command ;
+ERROR: message-contains-dot message ;
+
+M: message-contains-dot summary ( obj -- string )
+ drop
+ "Message cannot contain . on a line by itself" ;
+
: validate-message ( msg -- msg' )
- "." over member? [ "Message cannot contain . on a line by itself" throw ] when ;
+ "." over member?
+ [ message-contains-dot ] when ;
: send-body ( body -- )
string-lines
LOG: smtp-response DEBUG
+ERROR: smtp-error message ;
+ERROR: smtp-server-busy < smtp-error ;
+ERROR: smtp-syntax-error < smtp-error ;
+ERROR: smtp-command-not-implemented < smtp-error ;
+ERROR: smtp-bad-authentication < smtp-error ;
+ERROR: smtp-mailbox-unavailable < smtp-error ;
+ERROR: smtp-user-not-local < smtp-error ;
+ERROR: smtp-exceeded-storage-allocation < smtp-error ;
+ERROR: smtp-bad-mailbox-name < smtp-error ;
+ERROR: smtp-transaction-failed < smtp-error ;
+
: check-response ( response -- )
+ dup smtp-response
{
- { [ dup "220" head? ] [ smtp-response ] }
- { [ dup "235" swap subseq? ] [ smtp-response ] }
- { [ dup "250" head? ] [ smtp-response ] }
- { [ dup "221" head? ] [ smtp-response ] }
- { [ dup "bye" head? ] [ smtp-response ] }
- { [ dup "4" head? ] [ "server busy" throw ] }
- { [ dup "354" head? ] [ smtp-response ] }
- { [ dup "50" head? ] [ smtp-response "syntax error" throw ] }
- { [ dup "53" head? ] [ smtp-response "invalid authentication data" throw ] }
- { [ dup "55" head? ] [ smtp-response "fatal error" throw ] }
- [ "unknown error" throw ]
+ { [ dup "bye" head? ] [ drop ] }
+ { [ dup "220" head? ] [ drop ] }
+ { [ dup "235" swap subseq? ] [ drop ] }
+ { [ dup "250" head? ] [ drop ] }
+ { [ dup "221" head? ] [ drop ] }
+ { [ dup "354" head? ] [ drop ] }
+ { [ dup "4" head? ] [ smtp-server-busy ] }
+ { [ dup "500" head? ] [ smtp-syntax-error ] }
+ { [ dup "501" head? ] [ smtp-command-not-implemented ] }
+ { [ dup "50" head? ] [ smtp-syntax-error ] }
+ { [ dup "53" head? ] [ smtp-bad-authentication ] }
+ { [ dup "550" head? ] [ smtp-mailbox-unavailable ] }
+ { [ dup "551" head? ] [ smtp-user-not-local ] }
+ { [ dup "552" head? ] [ smtp-exceeded-storage-allocation ] }
+ { [ dup "553" head? ] [ smtp-bad-mailbox-name ] }
+ { [ dup "554" head? ] [ smtp-transaction-failed ] }
+ [ smtp-error ]
} cond ;
: multiline? ( response -- boolean )
: get-ok ( -- ) receive-response check-response ;
+ERROR: invalid-header-string string ;
+
: validate-header ( string -- string' )
dup "\r\n" intersect empty?
- [ "Invalid header string: " prepend throw ] unless ;
+ [ invalid-header-string ] unless ;
: write-header ( key value -- )
- swap
- validate-header write
- ": " write
- validate-header write
- crlf ;
+ [ validate-header write ]
+ [ ": " write validate-header write ] bi* crlf ;
: write-headers ( assoc -- )
[ write-header ] assoc-each ;
-TUPLE: email from to subject headers body ;
-
-M: email clone
- call-next-method [ clone ] change-headers ;
-
-: (send) ( email -- )
- [
- helo get-ok
- dup from>> mail-from get-ok
- dup to>> [ rcpt-to get-ok ] each
- data get-ok
- dup headers>> write-headers
- crlf
- body>> send-body get-ok
- quit get-ok
- ] with-smtp-connection ;
-
-: extract-email ( recepient -- email )
- #! This could be much smarter.
- " " last-split1 swap or "<" ?head drop ">" ?tail drop ;
-
: message-id ( -- string )
[
"<" %
">" %
] "" make ;
-: set-header ( email value key -- email )
- pick headers>> set-at ;
-
-: prepare ( email -- email )
- clone
- dup from>> "From" set-header
- [ extract-email ] change-from
- dup to>> ", " join "To" set-header
- [ [ extract-email ] map ] change-to
- dup subject>> "Subject" set-header
- now timestamp>rfc822 "Date" set-header
- message-id "Message-Id" set-header ;
+: extract-email ( recepient -- email )
+ #! This could be much smarter.
+ " " last-split1 swap or "<" ?head drop ">" ?tail drop ;
-: <email> ( -- email )
- email new
- H{ } clone >>headers ;
+: email>headers ( email -- hashtable )
+ [
+ {
+ [ from>> "From" set ]
+ [ to>> ", " join "To" set ]
+ [ cc>> ", " join [ "Cc" set ] unless-empty ]
+ [ subject>> "Subject" set ]
+ } cleave
+ now timestamp>rfc822 "Date" set
+ message-id "Message-Id" set
+ ] { } make-assoc ;
+
+: (send-email) ( headers email -- )
+ [
+ helo get-ok
+ dup from>> extract-email mail-from get-ok
+ dup to>> [ extract-email rcpt-to get-ok ] each
+ dup cc>> [ extract-email rcpt-to get-ok ] each
+ dup bcc>> [ extract-email rcpt-to get-ok ] each
+ data get-ok
+ swap write-headers
+ crlf
+ body>> send-body get-ok
+ quit get-ok
+ ] with-smtp-connection ;
: send-email ( email -- )
- prepare (send) ;
+ [ email>headers ] keep (send-email) ;
! Dirk's old AUTH CRAM-MD5 code. I don't know anything about
! CRAM MD5, and the old code didn't work properly either, so here
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces opengl opengl.gl ;
+IN: ui.backend
+
+SYMBOL: ui-backend
+
+HOOK: do-events ui-backend ( -- )
+
+HOOK: set-title ui-backend ( string world -- )
+
+HOOK: set-fullscreen* ui-backend ( ? world -- )
+
+HOOK: fullscreen* ui-backend ( world -- ? )
+
+HOOK: (open-window) ui-backend ( world -- )
+
+HOOK: (close-window) ui-backend ( handle -- )
+
+HOOK: raise-window* ui-backend ( world -- )
+
+HOOK: select-gl-context ui-backend ( handle -- )
+
+HOOK: flush-gl-context ui-backend ( handle -- )
+
+HOOK: beep ui-backend ( -- )
+
+: with-gl-context ( handle quot -- )
+ swap [ select-gl-context call ] keep
+ glFlush flush-gl-context gl-error ; inline
--- /dev/null
+UI backend hooks
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets ui.gestures help.markup help.syntax strings ;
+IN: ui.clipboards
+
+HELP: clipboard
+{ $var-description "Global variable holding the system clipboard. By convention, text should only be copied to the clipboard via an explicit user action, for example by pressing " { $snippet "C+c" } "." }
+{ $class-description "A mutable container for a single string implementing the " { $link "clipboard-protocol" } "." } ;
+
+HELP: paste-clipboard
+{ $values { "gadget" gadget } { "clipboard" "an object" } }
+{ $contract "Arranges for the contents of the clipboard to be inserted into the gadget at some point in the near future via a call to " { $link user-input } ". The gadget must be grafted." } ;
+
+HELP: copy-clipboard
+{ $values { "string" string } { "gadget" gadget } { "clipboard" "an object" } }
+{ $contract "Arranges for the string to be copied to the clipboard on behalf of the gadget. The gadget must be grafted." } ;
+
+HELP: selection
+{ $var-description "Global variable holding the system selection. By convention, text should be copied to the selection as soon as it is selected by the user." } ;
+
+ARTICLE: "clipboard-protocol" "Clipboard protocol"
+"Custom gadgets that wish to interact with the clipboard must use the following two generic words to read and write clipboard contents:"
+{ $subsection paste-clipboard }
+{ $subsection copy-clipboard }
+"UI backends can either implement the above two words in the case of an asynchronous clipboard model (for example, X11). If direct access to the clipboard is provided (Windows, Mac OS X), the following two generic words may be implemented instead:"
+{ $subsection clipboard-contents }
+{ $subsection set-clipboard-contents }
+"However, gadgets should not call these words, since they will fail if only the asynchronous method of clipboard access is supported by the backend in use."
+$nl
+"Access to two clipboards is provided:"
+{ $subsection clipboard }
+{ $subsection selection }
+"These variables may contain clipboard protocol implementations which transfer data to and from the native system clipboard. However an UI backend may leave one or both of these variables in their default state, which is a trivial clipboard implementation internal to the Factor UI." ;
+
+ABOUT: "clipboard-protocol"
--- /dev/null
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel ui.gadgets ui.gestures namespaces ;
+IN: ui.clipboards
+
+! Two text transfer buffers
+TUPLE: clipboard contents ;
+: <clipboard> ( -- clipboard ) "" clipboard boa ;
+
+GENERIC: paste-clipboard ( gadget clipboard -- )
+
+M: object paste-clipboard
+ clipboard-contents dup [ swap user-input ] [ 2drop ] if ;
+
+GENERIC: copy-clipboard ( string gadget clipboard -- )
+
+M: object copy-clipboard nip set-clipboard-contents ;
+
+SYMBOL: clipboard
+SYMBOL: selection
+
+: gadget-copy ( gadget clipboard -- )
+ over gadget-selection? [
+ >r [ gadget-selection ] keep r> copy-clipboard
+ ] [
+ 2drop
+ ] if ;
+
+: com-copy ( gadget -- ) clipboard get gadget-copy ;
+
+: com-copy-selection ( gadget -- ) selection get gadget-copy ;
--- /dev/null
+Abstract clipboard support
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math arrays cocoa cocoa.application
+command-line kernel memory namespaces cocoa.messages
+cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
+cocoa.windows cocoa.classes cocoa.application sequences system
+ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
+ui.cocoa.views core-foundation threads math.geometry.rect ;
+IN: ui.cocoa
+
+TUPLE: handle view window ;
+
+C: <handle> handle
+
+SINGLETON: cocoa-ui-backend
+
+M: cocoa-ui-backend do-events ( -- )
+ [
+ [ NSApp [ do-event ] curry loop ui-wait ] ui-try
+ ] with-autorelease-pool ;
+
+TUPLE: pasteboard handle ;
+
+C: <pasteboard> pasteboard
+
+M: pasteboard clipboard-contents
+ pasteboard-handle pasteboard-string ;
+
+M: pasteboard set-clipboard-contents
+ pasteboard-handle set-pasteboard-string ;
+
+: init-clipboard ( -- )
+ NSPasteboard -> generalPasteboard <pasteboard>
+ clipboard set-global
+ <clipboard> selection set-global ;
+
+: world>NSRect ( world -- NSRect )
+ dup window-loc>> first2 rot rect-dim first2 <NSRect> ;
+
+: gadget-window ( world -- )
+ [
+ dup <FactorView>
+ dup rot world>NSRect <ViewWindow>
+ dup install-window-delegate
+ over -> release
+ <handle>
+ ] keep set-world-handle ;
+
+M: cocoa-ui-backend set-title ( string world -- )
+ world-handle handle-window swap <NSString> -> setTitle: ;
+
+: enter-fullscreen ( world -- )
+ world-handle handle-view
+ NSScreen -> mainScreen
+ f -> enterFullScreenMode:withOptions:
+ drop ;
+
+: exit-fullscreen ( world -- )
+ world-handle handle-view f -> exitFullScreenModeWithOptions: ;
+
+M: cocoa-ui-backend set-fullscreen* ( ? world -- )
+ swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
+
+M: cocoa-ui-backend fullscreen* ( world -- ? )
+ world-handle handle-view -> isInFullScreenMode zero? not ;
+
+: auto-position ( world -- )
+ dup window-loc>> { 0 0 } = [
+ world-handle handle-window -> center
+ ] [
+ drop
+ ] if ;
+
+M: cocoa-ui-backend (open-window) ( world -- )
+ dup gadget-window
+ dup auto-position
+ world-handle handle-window f -> makeKeyAndOrderFront: ;
+
+M: cocoa-ui-backend (close-window) ( handle -- )
+ handle-window -> release ;
+
+M: cocoa-ui-backend close-window ( gadget -- )
+ find-world [
+ world-handle [
+ handle-window f -> performClose:
+ ] when*
+ ] when* ;
+
+M: cocoa-ui-backend raise-window* ( world -- )
+ world-handle [
+ handle-window dup f -> orderFront: -> makeKeyWindow
+ NSApp 1 -> activateIgnoringOtherApps:
+ ] when* ;
+
+M: cocoa-ui-backend select-gl-context ( handle -- )
+ handle-view -> openGLContext -> makeCurrentContext ;
+
+M: cocoa-ui-backend flush-gl-context ( handle -- )
+ handle-view -> openGLContext -> flushBuffer ;
+
+M: cocoa-ui-backend beep ( -- )
+ NSBeep ;
+
+SYMBOL: cocoa-init-hook
+
+M: cocoa-ui-backend ui
+ "UI" assert.app [
+ [
+ init-clipboard
+ cocoa-init-hook get [ call ] when*
+ start-ui
+ finish-launching
+ event-loop
+ ] ui-running
+ ] with-cocoa ;
+
+cocoa-ui-backend ui-backend set-global
+
+[ running.app? "ui" "listener" ? ] main-vocab-hook set-global
--- /dev/null
+Cocoa UI backend
--- /dev/null
+unportable
--- /dev/null
+Slava Pestov
--- /dev/null
+Cocoa integration for UI developer tools
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax cocoa cocoa.nibs cocoa.application
+cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing
+core-foundation help.topics kernel memory namespaces parser
+system ui ui.tools.browser ui.tools.listener ui.tools.workspace
+ui.cocoa eval ;
+IN: ui.cocoa.tools
+
+: finder-run-files ( alien -- )
+ CF>string-array listener-run-files
+ NSApp NSApplicationDelegateReplySuccess
+ -> replyToOpenOrPrint: ;
+
+: menu-run-files ( -- )
+ open-panel [ listener-run-files ] when* ;
+
+: menu-save-image ( -- )
+ image save-panel [ save-image ] when* ;
+
+! Handle Open events from the Finder
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "FactorApplicationDelegate" }
+}
+
+{ "application:openFiles:" "void" { "id" "SEL" "id" "id" }
+ [ >r 3drop r> finder-run-files ]
+}
+
+{ "newFactorWorkspace:" "id" { "id" "SEL" "id" }
+ [ 3drop workspace-window f ]
+}
+
+{ "runFactorFile:" "id" { "id" "SEL" "id" }
+ [ 3drop menu-run-files f ]
+}
+
+{ "saveFactorImage:" "id" { "id" "SEL" "id" }
+ [ 3drop save f ]
+}
+
+{ "saveFactorImageAs:" "id" { "id" "SEL" "id" }
+ [ 3drop menu-save-image f ]
+}
+
+{ "showFactorHelp:" "id" { "id" "SEL" "id" }
+ [ 3drop "handbook" com-follow f ]
+} ;
+
+: install-app-delegate ( -- )
+ NSApp FactorApplicationDelegate install-delegate ;
+
+! Service support; evaluate Factor code from other apps
+: do-service ( pboard error quot -- )
+ pick >r >r
+ ?pasteboard-string dup [ r> call ] [ r> 2drop f ] if
+ dup [ r> set-pasteboard-string ] [ r> 2drop ] if ;
+
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "FactorServiceProvider" }
+} {
+ "evalInListener:userData:error:"
+ "void"
+ { "id" "SEL" "id" "id" "void*" }
+ [ nip [ eval-listener f ] do-service 2drop ]
+} {
+ "evalToString:userData:error:"
+ "void"
+ { "id" "SEL" "id" "id" "void*" }
+ [ nip [ eval>string ] do-service 2drop ]
+} ;
+
+: register-services ( -- )
+ NSApp
+ FactorServiceProvider -> alloc -> init
+ -> setServicesProvider: ;
+
+FUNCTION: void NSUpdateDynamicServices ;
+
+[
+ install-app-delegate
+ "Factor.nib" load-nib
+ register-services
+] cocoa-init-hook set-global
--- /dev/null
+Slava Pestov
--- /dev/null
+Cocoa NSView implementation displaying Factor gadgets
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types arrays assocs cocoa kernel
+math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
+cocoa.application cocoa.pasteboard cocoa.types cocoa.windows
+sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
+core-foundation threads combinators math.geometry.rect ;
+IN: ui.cocoa.views
+
+: send-mouse-moved ( view event -- )
+ over >r mouse-location r> window move-hand fire-motion ;
+
+: button ( event -- n )
+ #! Cocoa -> Factor UI button mapping
+ -> buttonNumber H{ { 0 1 } { 2 2 } { 1 3 } } at ;
+
+: modifiers
+ {
+ { S+ HEX: 20000 }
+ { C+ HEX: 40000 }
+ { A+ HEX: 80000 }
+ { M+ HEX: 100000 }
+ } ;
+
+: key-codes
+ H{
+ { 71 "CLEAR" }
+ { 36 "RET" }
+ { 76 "ENTER" }
+ { 53 "ESC" }
+ { 48 "TAB" }
+ { 51 "BACKSPACE" }
+ { 115 "HOME" }
+ { 117 "DELETE" }
+ { 119 "END" }
+ { 122 "F1" }
+ { 120 "F2" }
+ { 99 "F3" }
+ { 118 "F4" }
+ { 96 "F5" }
+ { 97 "F6" }
+ { 98 "F7" }
+ { 100 "F8" }
+ { 123 "LEFT" }
+ { 124 "RIGHT" }
+ { 125 "DOWN" }
+ { 126 "UP" }
+ { 116 "PAGE_UP" }
+ { 121 "PAGE_DOWN" }
+ } ;
+
+: key-code ( event -- string ? )
+ dup -> keyCode key-codes at
+ [ t ] [ -> charactersIgnoringModifiers CF>string f ] ?if ;
+
+: event-modifiers ( event -- modifiers )
+ -> modifierFlags modifiers modifier ;
+
+: key-event>gesture ( event -- modifiers keycode action? )
+ dup event-modifiers swap key-code ;
+
+: send-key-event ( view event quot -- ? )
+ >r key-event>gesture r> call swap window-focus
+ send-gesture ; inline
+
+: send-user-input ( view string -- )
+ CF>string swap window-focus user-input ;
+
+: interpret-key-event ( view event -- )
+ NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
+
+: send-key-down-event ( view event -- )
+ 2dup [ <key-down> ] send-key-event
+ [ interpret-key-event ] [ 2drop ] if ;
+
+: send-key-up-event ( view event -- )
+ [ <key-up> ] send-key-event drop ;
+
+: mouse-event>gesture ( event -- modifiers button )
+ dup event-modifiers swap button ;
+
+: send-button-down$ ( view event -- )
+ [ mouse-event>gesture <button-down> ] 2keep
+ mouse-location rot window send-button-down ;
+
+: send-button-up$ ( view event -- )
+ [ mouse-event>gesture <button-up> ] 2keep
+ mouse-location rot window send-button-up ;
+
+: send-wheel$ ( view event -- )
+ over >r
+ dup -> deltaX sgn neg over -> deltaY sgn neg 2array -rot
+ mouse-location
+ r> window send-wheel ;
+
+: send-action$ ( view event gesture -- junk )
+ >r drop window r> send-action f ;
+
+: add-resize-observer ( observer object -- )
+ >r "updateFactorGadgetSize:"
+ "NSViewFrameDidChangeNotification" <NSString>
+ r> add-observer ;
+
+: string-or-nil? ( NSString -- ? )
+ [ CF>string NSStringPboardType = ] [ t ] if* ;
+
+: valid-service? ( gadget send-type return-type -- ? )
+ over string-or-nil? over string-or-nil? and [
+ drop [ gadget-selection? ] [ drop t ] if
+ ] [
+ 3drop f
+ ] if ;
+
+: NSRect>rect ( NSRect world -- rect )
+ >r dup NSRect-x over NSRect-y r>
+ rect-dim second swap - 2array
+ over NSRect-w rot NSRect-h 2array
+ <rect> ;
+
+: rect>NSRect ( rect world -- NSRect )
+ over rect-loc first2 rot rect-dim second swap -
+ rot rect-dim first2 <NSRect> ;
+
+CLASS: {
+ { +superclass+ "NSOpenGLView" }
+ { +name+ "FactorView" }
+ { +protocols+ { "NSTextInput" } }
+}
+
+! Rendering
+! Rendering
+{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
+ [ 3drop window relayout-1 ]
+}
+
+! Events
+{ "acceptsFirstMouse:" "bool" { "id" "SEL" "id" }
+ [ 3drop 1 ]
+}
+
+{ "mouseEntered:" "void" { "id" "SEL" "id" }
+ [ [ nip send-mouse-moved ] ui-try ]
+}
+
+{ "mouseExited:" "void" { "id" "SEL" "id" }
+ [ [ 3drop forget-rollover ] ui-try ]
+}
+
+{ "mouseMoved:" "void" { "id" "SEL" "id" }
+ [ [ nip send-mouse-moved ] ui-try ]
+}
+
+{ "mouseDragged:" "void" { "id" "SEL" "id" }
+ [ [ nip send-mouse-moved ] ui-try ]
+}
+
+{ "rightMouseDragged:" "void" { "id" "SEL" "id" }
+ [ [ nip send-mouse-moved ] ui-try ]
+}
+
+{ "otherMouseDragged:" "void" { "id" "SEL" "id" }
+ [ [ nip send-mouse-moved ] ui-try ]
+}
+
+{ "mouseDown:" "void" { "id" "SEL" "id" }
+ [ [ nip send-button-down$ ] ui-try ]
+}
+
+{ "mouseUp:" "void" { "id" "SEL" "id" }
+ [ [ nip send-button-up$ ] ui-try ]
+}
+
+{ "rightMouseDown:" "void" { "id" "SEL" "id" }
+ [ [ nip send-button-down$ ] ui-try ]
+}
+
+{ "rightMouseUp:" "void" { "id" "SEL" "id" }
+ [ [ nip send-button-up$ ] ui-try ]
+}
+
+{ "otherMouseDown:" "void" { "id" "SEL" "id" }
+ [ [ nip send-button-down$ ] ui-try ]
+}
+
+{ "otherMouseUp:" "void" { "id" "SEL" "id" }
+ [ [ nip send-button-up$ ] ui-try ]
+}
+
+{ "scrollWheel:" "void" { "id" "SEL" "id" }
+ [ [ nip send-wheel$ ] ui-try ]
+}
+
+{ "keyDown:" "void" { "id" "SEL" "id" }
+ [ [ nip send-key-down-event ] ui-try ]
+}
+
+{ "keyUp:" "void" { "id" "SEL" "id" }
+ [ [ nip send-key-up-event ] ui-try ]
+}
+
+{ "cut:" "id" { "id" "SEL" "id" }
+ [ [ nip T{ cut-action } send-action$ ] ui-try ]
+}
+
+{ "copy:" "id" { "id" "SEL" "id" }
+ [ [ nip T{ copy-action } send-action$ ] ui-try ]
+}
+
+{ "paste:" "id" { "id" "SEL" "id" }
+ [ [ nip T{ paste-action } send-action$ ] ui-try ]
+}
+
+{ "delete:" "id" { "id" "SEL" "id" }
+ [ [ nip T{ delete-action } send-action$ ] ui-try ]
+}
+
+{ "selectAll:" "id" { "id" "SEL" "id" }
+ [ [ nip T{ select-all-action } send-action$ ] ui-try ]
+}
+
+! Multi-touch gestures: this is undocumented.
+! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
+{ "magnifyWithEvent:" "void" { "id" "SEL" "id" }
+ [
+ nip
+ dup -> deltaZ sgn {
+ { 1 [ T{ zoom-in-action } send-action$ ] }
+ { -1 [ T{ zoom-out-action } send-action$ ] }
+ { 0 [ 2drop ] }
+ } case
+ ]
+}
+
+{ "swipeWithEvent:" "void" { "id" "SEL" "id" }
+ [
+ nip
+ dup -> deltaX sgn {
+ { 1 [ T{ left-action } send-action$ ] }
+ { -1 [ T{ right-action } send-action$ ] }
+ { 0
+ [
+ dup -> deltaY sgn {
+ { 1 [ T{ up-action } send-action$ ] }
+ { -1 [ T{ down-action } send-action$ ] }
+ { 0 [ 2drop ] }
+ } case
+ ]
+ }
+ } case
+ ]
+}
+
+! "rotateWithEvent:" "void" { "id" "SEL" "id" }}
+
+{ "acceptsFirstResponder" "bool" { "id" "SEL" }
+ [ 2drop 1 ]
+}
+
+! Services
+{ "validRequestorForSendType:returnType:" "id" { "id" "SEL" "id" "id" }
+ [
+ ! We return either self or nil
+ >r >r over window-focus r> r>
+ valid-service? [ drop ] [ 2drop f ] if
+ ]
+}
+
+{ "writeSelectionToPasteboard:types:" "bool" { "id" "SEL" "id" "id" }
+ [
+ CF>string-array NSStringPboardType swap member? [
+ >r drop window-focus gadget-selection dup [
+ r> set-pasteboard-string t
+ ] [
+ r> 2drop f
+ ] if
+ ] [
+ 3drop f
+ ] if
+ ]
+}
+
+{ "readSelectionFromPasteboard:" "bool" { "id" "SEL" "id" }
+ [
+ pasteboard-string dup [
+ >r drop window-focus r> swap user-input t
+ ] [
+ 3drop f
+ ] if
+ ]
+}
+
+! Text input
+{ "insertText:" "void" { "id" "SEL" "id" }
+ [ [ nip send-user-input ] ui-try ]
+}
+
+{ "hasMarkedText" "bool" { "id" "SEL" }
+ [ 2drop 0 ]
+}
+
+{ "markedRange" "NSRange" { "id" "SEL" }
+ [ 2drop 0 0 <NSRange> ]
+}
+
+{ "selectedRange" "NSRange" { "id" "SEL" }
+ [ 2drop 0 0 <NSRange> ]
+}
+
+{ "setMarkedText:selectedRange:" "void" { "id" "SEL" "id" "NSRange" }
+ [ 2drop 2drop ]
+}
+
+{ "unmarkText" "void" { "id" "SEL" }
+ [ 2drop ]
+}
+
+{ "validAttributesForMarkedText" "id" { "id" "SEL" }
+ [ 2drop NSArray -> array ]
+}
+
+{ "attributedSubstringFromRange:" "id" { "id" "SEL" "NSRange" }
+ [ 3drop f ]
+}
+
+{ "characterIndexForPoint:" "uint" { "id" "SEL" "NSPoint" }
+ [ 3drop 0 ]
+}
+
+{ "firstRectForCharacterRange:" "NSRect" { "id" "SEL" "NSRange" }
+ [ 3drop 0 0 0 0 <NSRect> ]
+}
+
+{ "conversationIdentifier" "long" { "id" "SEL" }
+ [ drop alien-address ]
+}
+
+! Initialization
+{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
+ [
+ [
+ 2drop dup view-dim swap window (>>dim) yield
+ ] ui-try
+ ]
+}
+
+{ "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }
+ [
+ rot drop
+ SUPER-> initWithFrame:pixelFormat:
+ dup dup add-resize-observer
+ ]
+}
+
+{ "dealloc" "void" { "id" "SEL" }
+ [
+ drop
+ dup unregister-window
+ dup remove-observer
+ SUPER-> dealloc
+ ]
+} ;
+
+: sync-refresh-to-screen ( GLView -- )
+ -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
+ CGLSetParameter drop ;
+
+: <FactorView> ( world -- view )
+ FactorView over rect-dim <GLView>
+ [ sync-refresh-to-screen ] keep
+ [ register-window ] keep ;
+
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "FactorWindowDelegate" }
+}
+
+{ "windowDidMove:" "void" { "id" "SEL" "id" }
+ [
+ 2nip -> object
+ dup window-content-rect NSRect-x-y 2array
+ swap -> contentView window (>>window-loc)
+ ]
+}
+
+{ "windowDidBecomeKey:" "void" { "id" "SEL" "id" }
+ [
+ 2nip -> object -> contentView window focus-world
+ ]
+}
+
+{ "windowDidResignKey:" "void" { "id" "SEL" "id" }
+ [
+ forget-rollover
+ 2nip -> object -> contentView window unfocus-world
+ ]
+}
+
+{ "windowShouldClose:" "bool" { "id" "SEL" "id" }
+ [
+ 3drop t
+ ]
+}
+
+{ "windowWillClose:" "void" { "id" "SEL" "id" }
+ [
+ 2nip -> object -> contentView window ungraft
+ ]
+} ;
+
+: install-window-delegate ( window -- )
+ FactorWindowDelegate install-delegate ;
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: accessors ui.gestures help.markup help.syntax strings kernel
+hashtables quotations words classes sequences namespaces
+arrays assocs ;
+IN: ui.commands
+
+: command-map-row ( gesture command -- seq )
+ [
+ [ gesture>string , ]
+ [
+ [ command-name , ]
+ [ command-word \ $link swap 2array , ]
+ [ command-description , ]
+ tri
+ ] bi*
+ ] { } make ;
+
+: command-map. ( alist -- )
+ [ command-map-row ] { } assoc>map
+ { "Shortcut" "Command" "Word" "Notes" }
+ [ \ $strong swap ] { } map>assoc prefix
+ $table ;
+
+: $command-map ( element -- )
+ [ second (command-name) " commands" append $heading ]
+ [
+ first2 swap command-map
+ [ blurb>> print-element ] [ commands>> command-map. ] bi
+ ] bi ;
+
+: $command ( element -- )
+ reverse first3 command-map
+ commands>> value-at gesture>string
+ $snippet ;
+
+HELP: +nullary+
+{ $description "A key which may be set in the hashtable passed to " { $link define-command } ". If set to a true value, the command does not take any inputs, and the value passed to " { $link invoke-command } " will be ignored. Otherwise, it takes one input." } ;
+
+HELP: +listener+
+{ $description "A key which may be set in the hashtable passed to " { $link define-command } ". If set to a true value, " { $link invoke-command } " will run the command in the listener. Otherwise it will run in the event loop." } ;
+
+HELP: +description+
+{ $description "A key which may be set in the hashtable passed to " { $link define-command } ". The value is a string displayed as part of the command's documentation by " { $link $command-map } "." } ;
+
+HELP: invoke-command
+{ $values { "target" object } { "command" "a command" } }
+{ $description "Invokes a command on the given target object." } ;
+
+{ invoke-command +nullary+ } related-words
+
+HELP: command-name
+{ $values { "command" "a command" } { "str" "a string" } }
+{ $description "Outputs a human-readable name for the command." }
+{ $examples
+ { $example
+ "USING: io ui.commands ;"
+ "IN: scratchpad"
+ ": com-my-command ;"
+ "\\ com-my-command command-name write"
+ "My Command"
+ }
+} ;
+
+HELP: command-description
+{ $values { "command" "a command" } { "str/f" "a string or " { $link f } } }
+{ $description "Outputs the command's description." } ;
+
+{ command-description +description+ } related-words
+
+HELP: command-word
+{ $values { "command" "a command" } { "word" word } }
+{ $description "Outputs the word that will be executed by " { $link invoke-command } ". This is only used for documentation purposes." } ;
+
+HELP: command-map
+{ $values { "group" string } { "class" "a class word" } { "command-map" "a " { $link command-map } " or " { $link f } } }
+{ $description "Outputs a named command map defined on a class." }
+{ $class-description "A command map stores a group of related commands. The " { $snippet "commands" } " slot stores an association list mapping gestures to commands, and the " { $snippet "blurb" } " slot stores an optional one-line description string of this command map."
+$nl
+"Command maps are created by calling " { $link <command-map> } " or " { $link define-command-map } "." } ;
+
+HELP: commands
+{ $values { "class" "a class word" } { "hash" hashtable } }
+{ $description "Outputs a hashtable mapping command map names to " { $link command-map } " instances." } ;
+
+HELP: define-command-map
+{ $values { "class" "a class word" } { "group" string } { "blurb" "a " { $link string } " or " { $link f } } { "pairs" "a sequence of gesture/word pairs" } }
+{ $description
+ "Defines a command map on the specified gadget class. The " { $snippet "specs" } " parameter is a sequence of pairs " { $snippet "{ gesture word }" } ". The words must be valid commands; see " { $link define-command } "."
+}
+{ $notes "Only one of " { $link define-command-map } " and " { $link set-gestures } " can be used on a given gadget class, since each word will overwrite the other word's definitions." } ;
+
+HELP: $command-map
+{ $values { "element" "a pair " { $snippet "{ class map }" } } }
+{ $description "Prints a command map, where the first element of the pair is a class word and the second is a command map name." } ;
+
+HELP: $command
+{ $values { "element" "a triple " { $snippet "{ class map command }" } } }
+{ $description "Prints the keyboard shortcut associated with " { $snippet "command" } " in the command map named " { $snippet "map" } " on the class " { $snippet "class" } "." } ;
+
+HELP: define-command
+{ $values { "word" word } { "hash" hashtable } }
+{ $description "Defines a command. The hashtable can contain the following keys:"
+ { $list
+ { { $link +nullary+ } " - if set to a true value, the word must have stack effect " { $snippet "( -- )" } "; otherwise it must have stack effect " { $snippet "( target -- )" } }
+ { { $link +listener+ } " - if set to a true value, the command will run in the listener" }
+ { { $link +description+ } " - can be set to a string description of the command" }
+ }
+} ;
+
+HELP: command-string
+{ $values { "gesture" "a gesture" } { "command" "a command" } { "string" string } }
+{ $description "Outputs a string containing the command name followed by the gesture." }
+{ $examples
+ { $example
+ "USING: io ui.commands ui.gestures ;"
+ "IN: scratchpad"
+ ": com-my-command ;"
+ "T{ key-down f { C+ } \"s\" } \\ com-my-command command-string write"
+ "My Command (C+s)"
+ }
+} ;
+
+ARTICLE: "ui-commands" "Commands"
+"Commands are an abstraction layered on top of gestures. Their main advantage is that they are identified by words and can be organized into " { $emphasis "command maps" } ". This allows easy construction of buttons and tool bars for invoking commands."
+{ $subsection define-command }
+"Command groups are defined on gadget classes:"
+{ $subsection define-command-map }
+"Commands can be introspected and invoked:"
+{ $subsection commands }
+{ $subsection command-map }
+{ $subsection invoke-command }
+"Gadgets for invoking commands are documented in " { $link "ui.gadgets.buttons" } "."
+$nl
+"When documenting gadgets, command documentation can be automatically generated:"
+{ $subsection $command-map }
+{ $subsection $command } ;
+
+ABOUT: "ui-commands"
--- /dev/null
+IN: ui.commands.tests
+USING: ui.commands ui.gestures tools.test help.markup io
+io.streams.string ;
+
+[ "A+a" ] [ T{ key-down f { A+ } "a" } gesture>string ] unit-test
+[ "b" ] [ T{ key-down f f "b" } gesture>string ] unit-test
+[ "Press Button 2" ] [ T{ button-down f f 2 } gesture>string ] unit-test
+
+: com-test-1 ;
+
+\ com-test-1 H{ } define-command
+
+[ [ 3 com-test-1 ] ] [ 3 \ com-test-1 command-quot ] unit-test
+
+: com-test-2 ;
+
+\ com-test-2 H{ { +nullary+ t } } define-command
+
+[ [ com-test-2 ] ] [ 3 \ com-test-2 command-quot ] unit-test
+
+SYMBOL: testing
+
+testing "testing" "hey" {
+ { T{ key-down f { C+ } "x" } com-test-1 }
+} define-command-map
+
+[ "C+x" ] [
+ [
+ { $command testing "testing" com-test-1 } print-element
+ ] with-string-writer
+] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays definitions kernel sequences strings
+math assocs words generic namespaces assocs quotations splitting
+ui.gestures unicode.case unicode.categories tr ;
+IN: ui.commands
+
+SYMBOL: +nullary+
+SYMBOL: +listener+
+SYMBOL: +description+
+
+PREDICATE: listener-command < word +listener+ word-prop ;
+
+GENERIC: invoke-command ( target command -- )
+
+GENERIC: command-name ( command -- str )
+
+TUPLE: command-map blurb commands ;
+
+GENERIC: command-description ( command -- str/f )
+
+GENERIC: command-word ( command -- word )
+
+: <command-map> ( blurb commands -- command-map )
+ { } like \ command-map boa ;
+
+: commands ( class -- hash )
+ dup "commands" word-prop [ ] [
+ H{ } clone [ "commands" set-word-prop ] keep
+ ] ?if ;
+
+: command-map ( group class -- command-map )
+ commands at ;
+
+: command-gestures ( class -- hash )
+ commands values [
+ [
+ commands>>
+ [ drop ] assoc-filter
+ [ [ invoke-command ] curry swap set ] assoc-each
+ ] each
+ ] H{ } make-assoc ;
+
+: update-gestures ( class -- )
+ dup command-gestures "gestures" set-word-prop ;
+
+: define-command-map ( class group blurb pairs -- )
+ <command-map>
+ swap pick commands set-at
+ update-gestures ;
+
+TR: convert-command-name "-" " " ;
+
+: (command-name) ( string -- newstring )
+ convert-command-name >title ;
+
+M: word command-name ( word -- str )
+ name>>
+ "com-" ?head drop
+ dup first Letter? [ rest ] unless
+ (command-name) ;
+
+M: word command-description ( word -- str )
+ +description+ word-prop ;
+
+: default-flags ( -- assoc )
+ H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
+
+: define-command ( word hash -- )
+ [ props>> ] [ default-flags swap assoc-union ] bi* update ;
+
+: command-quot ( target command -- quot )
+ dup 1quotation swap +nullary+ word-prop
+ [ nip ] [ curry ] if ;
+
+M: word invoke-command ( target command -- )
+ command-quot call ;
+
+M: word command-word ;
+
+M: f invoke-command ( target command -- ) 2drop ;
+
+: command-string ( gesture command -- string )
+ [
+ command-name %
+ gesture>string [ " (" % % ")" % ] when*
+ ] "" make ;
--- /dev/null
+UI command framework
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.syntax help.markup strings kernel alien opengl
+quotations ui.render io.styles freetype ;
+IN: ui.freetype
+
+HELP: freetype
+{ $values { "alien" alien } }
+{ $description "Outputs a native handle used by the FreeType library, initializing FreeType first if necessary." } ;
+
+HELP: open-fonts
+{ $var-description "Global variable. Hashtable mapping font descriptors to " { $link font } " instances." } ;
+
+{ font open-fonts open-font char-width string-width text-dim draw-string draw-text } related-words
+
+HELP: init-freetype
+{ $description "Initializes the FreeType library." }
+{ $notes "Do not call this word if you are using the UI." } ;
+
+HELP: font
+{ $class-description "A font which has been loaded by FreeType. Font instances have the following slots:"
+ { $list
+ { { $link font-ascent } ", " { $link font-descent } ", " { $link font-height } " - metrics." }
+ { { $link font-handle } " - alien pointer to an " { $snippet "FT_Face" } "." }
+ { { $link font-widths } " - sequence of character widths. Use " { $link char-width } " and " { $link string-width } " to compute string widths instead of reading this sequence directly." }
+ }
+} ;
+
+HELP: close-freetype
+{ $description "Closes the FreeType library." }
+{ $notes "Do not call this word if you are using the UI." } ;
+
+HELP: open-face
+{ $values { "font" string } { "style" "one of " { $link plain } ", " { $link bold } ", " { $link italic } " or " { $link bold-italic } } { "face" "alien pointer to an " { $snippet "FT_Face" } } }
+{ $description "Loads a TrueType font with the requested logical font name and style." }
+{ $notes "This is a low-level word. Call " { $link open-font } " instead." } ;
+
+HELP: render-glyph
+{ $values { "font" font } { "char" "a non-negative integer" } { "bitmap" alien } }
+{ $description "Renders a character and outputs a pointer to the bitmap." } ;
+
+HELP: <char-sprite>
+{ $values { "open-font" font } { "char" "a non-negative integer" } { "sprite" sprite } }
+{ $description "Renders a character to an OpenGL texture and records a display list which draws a quad with this texture. This word allocates native resources which must be freed by " { $link free-sprites } "." } ;
+
+HELP: (draw-string)
+{ $values { "open-font" font } { "sprites" "a vector of " { $link sprite } " instances" } { "string" string } { "loc" "a pair of integers" } }
+{ $description "Draws a line of text." }
+{ $notes "This is a low-level word, UI code should use " { $link draw-string } " or " { $link draw-text } " instead." }
+{ $side-effects "sprites" } ;
+
+HELP: run-char-widths
+{ $values { "open-font" font } { "string" string } { "widths" "a sequence of integers" } }
+{ $description "Outputs a sequence of x co-ordinates of the midpoint of each character in the string." }
+{ $notes "This word is used to convert x offsets to document locations, for example when the user moves the caret by clicking the mouse." } ;
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.accessors alien.c-types arrays io kernel libc
+math math.vectors namespaces opengl opengl.gl prettyprint assocs
+sequences io.files io.styles continuations freetype
+ui.gadgets.worlds ui.render ui.backend byte-arrays accessors
+locals ;
+
+IN: ui.freetype
+
+TUPLE: freetype-renderer ;
+
+SYMBOL: open-fonts
+
+: freetype-error ( n -- )
+ zero? [ "FreeType error" throw ] unless ;
+
+DEFER: freetype
+
+: init-freetype ( -- )
+ global [
+ f <void*> dup FT_Init_FreeType freetype-error
+ *void* \ freetype set
+ H{ } clone open-fonts set
+ ] bind ;
+
+: freetype ( -- alien )
+ \ freetype get-global expired? [ init-freetype ] when
+ \ freetype get-global ;
+
+TUPLE: font < identity-tuple
+ascent descent height handle widths ;
+
+M: font hashcode* drop font hashcode* ;
+
+: close-font ( font -- ) font-handle FT_Done_Face ;
+
+: close-freetype ( -- )
+ global [
+ open-fonts [ [ drop close-font ] assoc-each f ] change
+ freetype [ FT_Done_FreeType f ] change
+ ] bind ;
+
+M: freetype-renderer free-fonts ( world -- )
+ [ handle>> select-gl-context ]
+ [ fonts>> [ nip second free-sprites ] assoc-each ] bi ;
+
+: ttf-name ( font style -- name )
+ 2array H{
+ { { "monospace" plain } "VeraMono" }
+ { { "monospace" bold } "VeraMoBd" }
+ { { "monospace" bold-italic } "VeraMoBI" }
+ { { "monospace" italic } "VeraMoIt" }
+ { { "sans-serif" plain } "Vera" }
+ { { "sans-serif" bold } "VeraBd" }
+ { { "sans-serif" bold-italic } "VeraBI" }
+ { { "sans-serif" italic } "VeraIt" }
+ { { "serif" plain } "VeraSe" }
+ { { "serif" bold } "VeraSeBd" }
+ { { "serif" bold-italic } "VeraBI" }
+ { { "serif" italic } "VeraIt" }
+ } at ;
+
+: ttf-path ( name -- string )
+ "resource:fonts/" swap ".ttf" 3append ;
+
+: (open-face) ( path length -- face )
+ #! We use FT_New_Memory_Face, not FT_New_Face, since
+ #! FT_New_Face only takes an ASCII path name and causes
+ #! problems on localized versions of Windows
+ [ freetype ] 2dip 0 f <void*> [
+ FT_New_Memory_Face freetype-error
+ ] keep *void* ;
+
+: open-face ( font style -- face )
+ ttf-name ttf-path malloc-file-contents (open-face) ;
+
+SYMBOL: dpi
+
+72 dpi set-global
+
+: ft-floor -6 shift ; inline
+
+: ft-ceil 63 + -64 bitand -6 shift ; inline
+
+: font-units>pixels ( n font -- n )
+ face-size face-size-y-scale FT_MulFix ;
+
+: init-ascent ( font face -- font )
+ dup face-y-max swap font-units>pixels >>ascent ; inline
+
+: init-descent ( font face -- font )
+ dup face-y-min swap font-units>pixels >>descent ; inline
+
+: init-font ( font -- font )
+ dup handle>> init-ascent
+ dup handle>> init-descent
+ dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline
+
+: set-char-size ( handle size -- )
+ 0 swap 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ;
+
+: <font> ( handle -- font )
+ font new
+ H{ } clone >>widths
+ over first2 open-face >>handle
+ dup handle>> rot third set-char-size
+ init-font ;
+
+M: freetype-renderer open-font ( font -- open-font )
+ freetype drop open-fonts get [ <font> ] cache ;
+
+: load-glyph ( font char -- glyph )
+ >r font-handle dup r> 0 FT_Load_Char
+ freetype-error face-glyph ;
+
+: char-width ( open-font char -- w )
+ over font-widths [
+ dupd load-glyph glyph-hori-advance ft-ceil
+ ] cache nip ;
+
+M: freetype-renderer string-width ( open-font string -- w )
+ 0 -rot [ char-width + ] with each ;
+
+M: freetype-renderer string-height ( open-font string -- h )
+ drop font-height ;
+
+: glyph-size ( glyph -- dim )
+ dup glyph-hori-advance ft-ceil
+ swap glyph-height ft-ceil 2array ;
+
+: render-glyph ( font char -- bitmap )
+ load-glyph dup
+ FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
+
+:: copy-pixel ( i j bitmap texture -- i j )
+ 255 j texture set-char-nth
+ i bitmap char-nth j 1 + texture set-char-nth
+ i 1 + j 2 + ; inline
+
+:: (copy-row) ( i j bitmap texture end -- )
+ i end < [
+ i j bitmap texture copy-pixel
+ bitmap texture end (copy-row)
+ ] when ; inline recursive
+
+:: copy-row ( i j bitmap texture width width2 -- i j )
+ i j bitmap texture i width + (copy-row)
+ i width +
+ j width2 + ; inline
+
+:: copy-bitmap ( glyph texture -- )
+ [let* | bitmap [ glyph glyph-bitmap-buffer ]
+ rows [ glyph glyph-bitmap-rows ]
+ width [ glyph glyph-bitmap-width ]
+ width2 [ width next-power-of-2 2 * ] |
+ 0 0
+ rows [ bitmap texture width width2 copy-row ] times
+ 2drop
+ ] ;
+
+: bitmap>texture ( glyph sprite -- id )
+ tuck sprite-size2 * 2 * [
+ [ copy-bitmap ] keep gray-texture
+ ] with-malloc ;
+
+: glyph-texture-loc ( glyph font -- loc )
+ over glyph-hori-bearing-x ft-floor -rot
+ font-ascent swap glyph-hori-bearing-y - ft-floor 2array ;
+
+: glyph-texture-size ( glyph -- dim )
+ [ glyph-bitmap-width next-power-of-2 ]
+ [ glyph-bitmap-rows next-power-of-2 ]
+ bi 2array ;
+
+: <char-sprite> ( open-font char -- sprite )
+ over >r render-glyph dup r> glyph-texture-loc
+ over glyph-size pick glyph-texture-size <sprite>
+ [ bitmap>texture ] keep [ init-sprite ] keep ;
+
+:: char-sprite ( open-font sprites char -- sprite )
+ char sprites [ open-font swap <char-sprite> ] cache ;
+
+: draw-char ( open-font sprites char loc -- )
+ GL_MODELVIEW [
+ 0 0 glTranslated
+ char-sprite sprite-dlist glCallList
+ ] do-matrix ;
+
+: char-widths ( open-font string -- widths )
+ [ char-width ] with { } map-as ;
+
+: scan-sums ( seq -- seq' )
+ 0 [ + ] accumulate nip ;
+
+:: (draw-string) ( open-font sprites string loc -- )
+ GL_TEXTURE_2D [
+ loc [
+ string open-font string char-widths scan-sums [
+ [ open-font sprites ] 2dip draw-char
+ ] 2each
+ ] with-translation
+ ] do-enabled ;
+
+: font-sprites ( font world -- open-font sprites )
+ world-fonts [ open-font H{ } clone 2array ] cache first2 ;
+
+M: freetype-renderer draw-string ( font string loc -- )
+ >r >r world get font-sprites r> r> (draw-string) ;
+
+: run-char-widths ( open-font string -- widths )
+ char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
+
+M: freetype-renderer x>offset ( x open-font string -- n )
+ dup >r run-char-widths [ <= ] with find drop
+ [ r> drop ] [ r> length ] if* ;
+
+T{ freetype-renderer } font-renderer set-global
--- /dev/null
+UI text rendering implementation based on FreeType
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax ui.gadgets models ;
+IN: ui.gadgets.books
+
+HELP: book
+{ $class-description "A book is a control containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $link gadget-visible? } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget."
+$nl
+"Books are created by calling " { $link <book> } "." } ;
+
+HELP: <book>
+{ $values { "pages" "a sequence of gadgets" } { "model" model } { "book" book } }
+{ $description "Creates a " { $link book } " control, which contains the gadgets in " { $snippet "pages" } ". A book shows one child at a time, determined by the value of the model, which must be an integer " } ;
+
+ARTICLE: "ui-book-layout" "Book layouts"
+"Books can contain any number of children, and display one child at a time."
+{ $subsection book }
+{ $subsection <book> } ;
+
+ABOUT: "ui-book-layout"
--- /dev/null
+IN: ui.gadgets.books.tests
+USING: tools.test ui.gadgets.books ;
+
+\ <book> must-infer
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences models ui.gadgets math.geometry.rect ;
+IN: ui.gadgets.books
+
+TUPLE: book < gadget ;
+
+: hide-all ( book -- ) gadget-children [ hide-gadget ] each ;
+
+: current-page ( book -- gadget ) [ control-value ] keep nth-gadget ;
+
+M: book model-changed ( model book -- )
+ nip
+ dup hide-all
+ dup current-page show-gadget
+ relayout ;
+
+: new-book ( pages model class -- book )
+ new-gadget
+ swap >>model
+ swap add-gadgets ; inline
+
+: <book> ( pages model -- book ) book new-book ;
+
+M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
+
+M: book layout* ( book -- )
+ [ dim>> ] [ children>> ] bi [ (>>dim) ] with each ;
+
+M: book focusable-child* ( book -- child/t ) current-page ;
--- /dev/null
+Book gadget displays one child at a time
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax ui.gadgets math ;
+IN: ui.gadgets.borders
+
+HELP: border
+{ $class-description "A border gadget contains a single child and centers it, with a fixed-width border. Borders are created by calling " { $link <border> } "." } ;
+
+HELP: <border>
+{ $values { "child" gadget } { "gap" integer } { "border" "a new " { $link border } } }
+{ $description "Creates a new border around the child with the specified horizontal and vertical gap." } ;
+
+ARTICLE: "ui.gadgets.borders" "Border gadgets"
+"Border gadgets add empty space around a child gadget."
+{ $subsection border }
+{ $subsection <border> } ;
+
+ABOUT: "ui.gadgets.borders"
--- /dev/null
+IN: ui.gadgets.borders.tests
+USING: tools.test accessors namespaces kernel
+ui.gadgets ui.gadgets.borders math.geometry.rect ;
+
+[ { 110 210 } ] [ <gadget> { 100 200 } >>dim 5 <border> pref-dim ] unit-test
+
+[ ] [ <gadget> { 100 200 } >>dim "g" set ] unit-test
+
+[ ] [ "g" get 0 <border> { 100 200 } >>dim "b" set ] unit-test
+
+[ T{ rect f { 0 0 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
+
+[ ] [ "g" get 5 <border> { 210 210 } >>dim "b" set ] unit-test
+
+[ T{ rect f { 55 5 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
+
+[ ] [ "b" get { 0 0 } >>align drop ] unit-test
+
+[ { 5 5 } ] [ "b" get { 100 200 } border-loc ] unit-test
+
+[ T{ rect f { 5 5 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
+
+[ ] [ "b" get { 1 1 } >>fill drop ] unit-test
+
+[ T{ rect f { 5 5 } { 200 200 } } ] [ "b" get border-child-rect ] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays ui.gadgets kernel math
+namespaces vectors sequences math.vectors math.geometry.rect ;
+IN: ui.gadgets.borders
+
+TUPLE: border < gadget
+{ size initial: { 0 0 } }
+{ fill initial: { 0 0 } }
+{ align initial: { 1/2 1/2 } } ;
+
+: new-border ( child class -- border )
+ new-gadget [ swap add-gadget drop ] keep ; inline
+
+: <border> ( child gap -- border )
+ swap border new-border
+ swap dup 2array >>size ;
+
+M: border pref-dim*
+ [ size>> 2 v*n ] keep
+ gadget-child pref-dim v+ ;
+
+: border-major-dim ( border -- dim )
+ [ dim>> ] [ size>> 2 v*n ] bi v- ;
+
+: border-minor-dim ( border -- dim )
+ gadget-child pref-dim ;
+
+: scale ( a b s -- c )
+ tuck { 1 1 } swap v- [ v* ] 2bi@ v+ ;
+
+: border-dim ( border -- dim )
+ [ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ;
+
+: border-loc ( border dim -- loc )
+ [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip
+ v- v* v+ [ >fixnum ] map ;
+
+: border-child-rect ( border -- rect )
+ dup border-dim [ border-loc ] keep <rect> ;
+
+M: border layout*
+ dup border-child-rect swap gadget-child
+ over loc>> over set-rect-loc
+ swap dim>> swap (>>dim) ;
+
+M: border focusable-child*
+ gadget-child ;
--- /dev/null
+Border gadget adds padding around a child
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax ui.gadgets ui.gadgets.labels
+ui.render kernel models classes ;
+IN: ui.gadgets.buttons
+
+HELP: button
+{ $class-description "A button is a " { $link gadget } " which responds to mouse clicks by invoking a quotation."
+$nl
+"A button's appearance can vary depending on the state of the mouse button if the " { $link gadget-interior } " or " { $link gadget-boundary } " slots are set to instances of " { $link button-paint } "."
+$nl
+"A button can be selected, which is distinct from being pressed. This state is held in the " { $link button-selected? } " slot, and is used by the " { $link <toggle-buttons> } " word to construct a row of buttons for choosing among several alternatives." } ;
+
+HELP: <button>
+{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" "a new " { $link button } } }
+{ $description "Creates a new " { $link button } " which calls the quotation when clicked. The given gadget becomes the button's only child." } ;
+
+HELP: <roll-button>
+{ $values { "label" "a label specifier" } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" button } }
+{ $description "Creates a new " { $link button } " which is displayed with a solid border when it is under the mouse, informing the user that the gadget is clickable." } ;
+
+HELP: <bevel-button>
+{ $values { "label" "a label specifier" } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" button } }
+{ $description "Creates a new " { $link button } " with a shaded border which is always visible. The button appearance changes in response to mouse gestures using a " { $link button-paint } "." } ;
+
+HELP: <repeat-button>
+{ $values { "label" object } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" repeat-button } }
+{ $description "Creates a new " { $link button } " derived from a " { $link <bevel-button> } " which calls the quotation every 100 milliseconds as long as the mouse button is held down." } ;
+
+HELP: button-paint
+{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " gneeric words by delegating to an object in one of four slots which depend on the state of the button being drawn:"
+ { $list
+ { { $link button-paint-plain } " - the button is inactive" }
+ { { $link button-paint-rollover } " - the button is under the mouse" }
+ { { $link button-paint-pressed } " - the button is under the mouse and a mouse button is held down" }
+ { { $link button-paint-selected } " - the button is selected (see " { $link <toggle-buttons> } }
+ }
+"The " { $link <roll-button> } " and " { $link <bevel-button> } " words create " { $link button } " instances with specific " { $link button-paint } "." } ;
+
+HELP: <toggle-button>
+{ $values { "model" model } { "value" object } { "label" "a label specifier" } { "gadget" gadget } }
+{ $description
+ "Creates a " { $link <bevel-button> } " which sets the model's value to " { $snippet "value" } " when pressed. After being pressed, the button becomes selected until the value of the model changes again."
+}
+{ $notes "Typically a row of radio controls should be built together using " { $link <toggle-buttons> } "." } ;
+
+HELP: <toggle-buttons>
+{ $values { "model" model } { "assoc" "an association list mapping labels to objects" } { "gadget" gadget } }
+{ $description "Creates a row of labelled " { $link <toggle-button> } " gadgets which change the value of the model." } ;
+
+HELP: <command-button>
+{ $values { "target" object } { "gesture" "a gesture" } { "command" "a command" } { "button" "a new " { $link button } } }
+{ $description "Creates a " { $link <bevel-button> } " which invokes the command on " { $snippet "target" } " when clicked." } ;
+
+HELP: <toolbar>
+{ $values { "target" object } { "toolbar" gadget } }
+{ $description "Creates a row of " { $link <command-button> } " gadgets invoking commands on " { $snippet "target" } ". The commands are taken from the " { $snippet "\"toolbar\"" } " command group of each class in " { $snippet "classes" } "." } ;
+
+ARTICLE: "ui.gadgets.buttons" "Button gadgets"
+"Buttons respond to mouse clicks by invoking a quotation."
+{ $subsection button }
+"There are many ways to create a new button:"
+{ $subsection <button> }
+{ $subsection <roll-button> }
+{ $subsection <bevel-button> }
+{ $subsection <repeat-button> }
+"Gadgets for invoking commands:"
+{ $subsection <command-button> }
+{ $subsection <toolbar> }
+"A radio box is a row of buttons for choosing amongst several distinct possibilities:"
+{ $subsection <toggle-buttons> }
+"Button appearance can be customized:"
+{ $subsection button-paint }
+"Button constructors take " { $emphasis "label specifiers" } " as input. A label specifier is either a string, an array of strings, a gadget or " { $link f } "."
+{ $see-also <command-button> "ui-commands" } ;
--- /dev/null
+IN: ui.gadgets.buttons.tests
+USING: ui.commands ui.gadgets.buttons ui.gadgets.labels
+ui.gadgets tools.test namespaces sequences kernel models ;
+
+TUPLE: foo-gadget ;
+
+: com-foo-a ;
+
+: com-foo-b ;
+
+\ foo-gadget "toolbar" f {
+ { f com-foo-a }
+ { f com-foo-b }
+} define-command-map
+
+T{ foo-gadget } <toolbar> "t" set
+
+[ 2 ] [ "t" get gadget-children length ] unit-test
+[ "Foo A" ] [ "t" get gadget-child gadget-child label-string ] unit-test
+
+[ ] [
+ 2 <model> {
+ { 0 "atheist" }
+ { 1 "christian" }
+ { 2 "muslim" }
+ { 3 "jewish" }
+ } <radio-buttons> "religion" set
+] unit-test
+
+\ <radio-buttons> must-infer
+
+\ <toggle-buttons> must-infer
+
+\ <checkbox> must-infer
+
+[ 0 ] [
+ "religion" get gadget-child radio-control-value
+] unit-test
+
+[ 2 ] [
+ "religion" get gadget-child control-value
+] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel math models namespaces sequences
+ strings quotations assocs combinators classes colors
+ classes.tuple opengl math.vectors
+ ui.commands ui.gadgets ui.gadgets.borders
+ ui.gadgets.labels ui.gadgets.theme
+ ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
+ ui.render math.geometry.rect ;
+
+IN: ui.gadgets.buttons
+
+TUPLE: button < border pressed? selected? quot ;
+
+: buttons-down? ( -- ? )
+ hand-buttons get-global empty? not ;
+
+: button-rollover? ( button -- ? )
+ hand-gadget get-global child? ;
+
+: mouse-clicked? ( gadget -- ? )
+ hand-clicked get-global child? ;
+
+: button-update ( button -- )
+ dup mouse-clicked?
+ over button-rollover? and
+ buttons-down? and
+ over set-button-pressed?
+ relayout-1 ;
+
+: if-clicked ( button quot -- )
+ >r dup button-update dup button-rollover? r> [ drop ] if ;
+
+: button-clicked ( button -- )
+ dup button-quot if-clicked ;
+
+button H{
+ { T{ button-up } [ button-clicked ] }
+ { T{ button-down } [ button-update ] }
+ { T{ mouse-leave } [ button-update ] }
+ { T{ mouse-enter } [ button-update ] }
+} set-gestures
+
+: new-button ( label quot class -- button )
+ [ swap >label ] dip new-border swap >>quot ; inline
+
+: <button> ( label quot -- button )
+ button new-button ;
+
+TUPLE: button-paint plain rollover pressed selected ;
+
+C: <button-paint> button-paint
+
+: find-button ( gadget -- button )
+ [ [ button? ] is? ] find-parent ;
+
+: button-paint ( button paint -- button paint )
+ over find-button {
+ { [ dup pressed?>> ] [ drop pressed>> ] }
+ { [ dup selected?>> ] [ drop selected>> ] }
+ { [ dup button-rollover? ] [ drop rollover>> ] }
+ [ drop plain>> ]
+ } cond ;
+
+M: button-paint draw-interior
+ button-paint draw-interior ;
+
+M: button-paint draw-boundary
+ button-paint draw-boundary ;
+
+: roll-button-theme ( button -- button )
+ f black <solid> dup f <button-paint> >>boundary
+ { 0 1/2 } >>align ; inline
+
+: <roll-button> ( label quot -- button )
+ <button> roll-button-theme ;
+
+: <bevel-button-paint> ( -- paint )
+ plain-gradient
+ rollover-gradient
+ pressed-gradient
+ selected-gradient
+ <button-paint> ;
+
+: bevel-button-theme ( gadget -- gadget )
+ <bevel-button-paint> >>interior
+ { 5 5 } >>size
+ faint-boundary ; inline
+
+: <bevel-button> ( label quot -- button )
+ <button> bevel-button-theme ;
+
+TUPLE: repeat-button < button ;
+
+repeat-button H{
+ { T{ drag } [ button-clicked ] }
+} set-gestures
+
+: <repeat-button> ( label quot -- button )
+ #! Button that calls the quotation every 100ms as long as
+ #! the mouse is held down.
+ repeat-button new-button bevel-button-theme ;
+
+TUPLE: checkmark-paint color ;
+
+C: <checkmark-paint> checkmark-paint
+
+M: checkmark-paint draw-interior
+ checkmark-paint-color set-color
+ origin get [
+ rect-dim
+ { 0 0 } over gl-line
+ dup { 0 1 } v* swap { 1 0 } v* gl-line
+ ] with-translation ;
+
+: checkmark-theme ( gadget -- )
+ f
+ f
+ black <solid>
+ black <checkmark-paint>
+ <button-paint>
+ over set-gadget-interior
+ black <solid>
+ swap set-gadget-boundary ;
+
+: <checkmark> ( -- gadget )
+ <gadget>
+ dup checkmark-theme
+ { 14 14 } over (>>dim) ;
+
+: toggle-model ( model -- )
+ [ not ] change-model ;
+
+: checkbox-theme ( gadget -- gadget )
+ f >>interior
+ { 5 5 } >>gap
+ 1/2 >>align ; inline
+
+TUPLE: checkbox < button ;
+
+: <checkbox> ( model label -- checkbox )
+ <checkmark> label-on-right checkbox-theme
+ [ model>> toggle-model ]
+ checkbox new-button
+ swap >>model ;
+
+M: checkbox model-changed
+ swap model-value over set-button-selected? relayout-1 ;
+
+TUPLE: radio-paint color ;
+
+C: <radio-paint> radio-paint
+
+M: radio-paint draw-interior
+ radio-paint-color set-color
+ origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
+
+M: radio-paint draw-boundary
+ radio-paint-color set-color
+ origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
+
+: radio-knob-theme ( gadget -- )
+ f
+ f
+ black <radio-paint>
+ black <radio-paint>
+ <button-paint>
+ over set-gadget-interior
+ black <radio-paint>
+ swap set-gadget-boundary ;
+
+: <radio-knob> ( -- gadget )
+ <gadget>
+ dup radio-knob-theme
+ { 16 16 } over (>>dim) ;
+
+TUPLE: radio-control < button value ;
+
+: <radio-control> ( value model label -- control )
+ [ [ value>> ] keep set-control-value ]
+ radio-control new-button
+ swap >>model
+ swap >>value ; inline
+
+M: radio-control model-changed
+ swap model-value
+ over radio-control-value =
+ over set-button-selected?
+ relayout-1 ;
+
+: <radio-controls> ( parent model assoc quot -- parent )
+ #! quot has stack effect ( value model label -- )
+ swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
+
+: radio-button-theme ( gadget -- gadget )
+ { 5 5 } >>gap
+ 1/2 >>align ; inline
+
+: <radio-button> ( value model label -- gadget )
+ <radio-knob> label-on-right radio-button-theme <radio-control> ;
+
+: <radio-buttons> ( model assoc -- gadget )
+ <filled-pile>
+ -rot
+ [ <radio-button> ] <radio-controls>
+ { 5 5 } >>gap ;
+
+: <toggle-button> ( value model label -- gadget )
+ <radio-control> bevel-button-theme ;
+
+: <toggle-buttons> ( model assoc -- gadget )
+ <shelf>
+ -rot
+ [ <toggle-button> ] <radio-controls> ;
+
+: command-button-quot ( target command -- quot )
+ [ invoke-command drop ] 2curry ;
+
+: <command-button> ( target gesture command -- button )
+ [ command-string ] keep
+ swapd
+ command-button-quot
+ <bevel-button> ;
+
+: <toolbar> ( target -- toolbar )
+ <shelf>
+ swap
+ "toolbar" over class command-map commands>> swap
+ [ -rot <command-button> add-gadget ] curry assoc-each ;
--- /dev/null
+Button gadgets invoke commands when clicked
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ui.backend ui.gadgets ui.gadgets.theme ui.gadgets.lib
+ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces
+classes.tuple colors ;
+IN: ui.gadgets.canvas
+
+TUPLE: canvas < gadget dlist ;
+
+: <canvas> ( -- canvas )
+ canvas new-gadget
+ black solid-interior ;
+
+: delete-canvas-dlist ( canvas -- )
+ dup find-gl-context
+ dup canvas-dlist [ delete-dlist ] when*
+ f swap set-canvas-dlist ;
+
+: make-canvas-dlist ( canvas quot -- dlist )
+ over >r GL_COMPILE swap make-dlist dup r>
+ set-canvas-dlist ;
+
+: cache-canvas-dlist ( canvas quot -- dlist )
+ over canvas-dlist dup
+ [ 2nip ] [ drop make-canvas-dlist ] if ; inline
+
+: draw-canvas ( canvas quot -- )
+ origin get [
+ cache-canvas-dlist glCallList
+ ] with-translation ; inline
+
+M: canvas ungraft* delete-canvas-dlist ;
--- /dev/null
+
+USING: kernel combinators sequences opengl.gl
+ ui.render ui.gadgets ui.gadgets.slate
+ accessors ;
+
+IN: ui.gadgets.cartesian
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: cartesian < slate x-min x-max y-min y-max z-min z-max perspective ;
+
+: init-cartesian ( cartesian -- cartesian )
+ init-slate
+ -10 >>x-min
+ 10 >>x-max
+ -10 >>y-min
+ 10 >>y-max
+ -1 >>z-min
+ 1 >>z-max ;
+
+: <cartesian> ( -- cartesian ) cartesian new init-cartesian ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: cartesian establish-coordinate-system ( cartesian -- cartesian )
+ dup
+ {
+ [ x-min>> ] [ x-max>> ]
+ [ y-min>> ] [ y-max>> ]
+ [ z-min>> ] [ z-max>> ]
+ }
+ cleave
+ glOrtho ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: x-range ( cartesian range -- cartesian ) first2 [ >>x-min ] [ >>x-max ] bi* ;
+: y-range ( cartesian range -- cartesian ) first2 [ >>y-min ] [ >>y-max ] bi* ;
+: z-range ( cartesian range -- cartesian ) first2 [ >>z-min ] [ >>z-max ] bi* ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: documents help.markup help.syntax ui.gadgets
+ui.gadgets.scrollers models strings ui.commands ;
+IN: ui.gadgets.editors
+
+HELP: editor
+{ $class-description "An editor is a control for editing a multi-line passage of text stored in a " { $link document } " model. Editors are crated by calling " { $link <editor> } "."
+$nl
+"Editors have the following slots:"
+{ $list
+ { { $link editor-font } " - a font specifier." }
+ { { $link editor-color } " - text color specifier." }
+ { { $link editor-caret-color } " - caret color specifier." }
+ { { $link editor-selection-color } " - selection background color specifier." }
+ { { $link editor-caret } " - a model storing a line/column pair." }
+ { { $link editor-mark } " - a model storing a line/column pair. If there is no selection, the mark is equal to the caret, otherwise the mark is located at the opposite end of the selection from the caret." }
+ { { $link editor-focused? } " - a boolean." }
+} } ;
+
+HELP: <editor>
+{ $values { "editor" "a new " { $link editor } } }
+{ $description "Creates a new " { $link editor } " with an empty document." } ;
+
+HELP: editor-caret ( editor -- caret )
+{ $values { "editor" editor } { "caret" model } }
+{ $description "Outputs a " { $link model } " holding the current caret location." } ;
+
+{ editor-caret editor-caret* editor-mark editor-mark* } related-words
+
+HELP: editor-caret*
+{ $values { "editor" editor } { "loc" "a pair of integers" } }
+{ $description "Outputs the current caret location as a line/column number pair." } ;
+
+HELP: editor-mark ( editor -- mark )
+{ $values { "editor" editor } { "mark" model } }
+{ $description "Outputs a " { $link model } " holding the current mark location." } ;
+
+HELP: editor-mark*
+{ $values { "editor" editor } { "loc" "a pair of integers" } }
+{ $description "Outputs the current mark location as a line/column number pair." } ;
+
+HELP: change-caret
+{ $values { "editor" editor } { "quot" "a quotation with stack effect " { $snippet "( loc -- newloc )" } } }
+{ $description "Applies a quotation to the current caret location and moves the caret to the location output by the quotation." } ;
+
+{ change-caret change-caret&mark mark>caret } related-words
+
+HELP: mark>caret
+{ $values { "editor" editor } }
+{ $description "Moves the mark to the caret location, effectively deselecting any selected text." } ;
+
+HELP: change-caret&mark
+{ $values { "editor" editor } { "quot" "a quotation with stack effect " { $snippet "( loc -- newloc )" } } }
+{ $description "Applies a quotation to the current caret location and moves the caret and the mark to the location output by the quotation." } ;
+
+HELP: point>loc
+{ $values { "point" "a pair of integers" } { "editor" editor } { "loc" "a pair of integers" } }
+{ $description "Converts a point to a line/column number pair." } ;
+
+HELP: scroll>caret
+{ $values { "editor" editor } }
+{ $description "Ensures that the caret becomes visible in a " { $link scroller } " containing the editor. Does nothing if no parent of " { $snippet "gadget" } " is a " { $link scroller } "." } ;
+
+HELP: remove-selection
+{ $values { "editor" editor } }
+{ $description "Removes currently selected text from the editor's " { $link document } "." } ;
+
+HELP: editor-string
+{ $values { "editor" editor } { "string" string } }
+{ $description "Outputs the contents of the editor's " { $link document } " as a string. Lines are separated by " { $snippet "\\n" } "." } ;
+
+HELP: set-editor-string
+{ $values { "string" string } { "editor" editor } }
+{ $description "Sets the contents of the editor's " { $link document } " to a string, which may use either " { $snippet "\\n" } ", " { $snippet "\\r\\n" } " or " { $snippet "\\r" } " line separators." } ;
+
+ARTICLE: "gadgets-editors-selection" "The caret and mark"
+"If there is no selection, the caret and the mark are at the same location; otherwise the mark delimits the end-point of the selection opposite the caret."
+{ $subsection editor-caret }
+{ $subsection editor-caret* }
+{ $subsection editor-mark }
+{ $subsection editor-mark* }
+{ $subsection change-caret }
+{ $subsection change-caret&mark }
+{ $subsection mark>caret }
+"Getting the selected text:"
+{ $subsection gadget-selection? }
+{ $subsection gadget-selection }
+"Removing selected text:"
+{ $subsection remove-selection }
+"Scrolling to the caret location:"
+{ $subsection scroll>caret }
+"Use " { $link user-input* } " to change selected text." ;
+
+ARTICLE: "gadgets-editors" "Editor gadgets"
+"An editor edits a multi-line passage of text."
+{ $command-map editor "general" }
+{ $command-map editor "caret-motion" }
+{ $command-map editor "selection" }
+{ $heading "Editor words" }
+{ $subsection editor }
+{ $subsection <editor> }
+{ $subsection editor-string }
+{ $subsection set-editor-string }
+{ $subsection "gadgets-editors-selection" }
+{ $subsection "documents" }
+{ $subsection "document-locs-elts" } ;
+
+ABOUT: "gadgets-editors"
--- /dev/null
+USING: accessors ui.gadgets.editors tools.test kernel io
+io.streams.plain definitions namespaces ui.gadgets
+ui.gadgets.grids prettyprint documents ui.gestures tools.test.ui
+models ;
+
+[ "foo bar" ] [
+ <editor> "editor" set
+ "editor" get [
+ "foo bar" "editor" get set-editor-string
+ "editor" get T{ one-line-elt } select-elt
+ "editor" get gadget-selection
+ ] with-grafted-gadget
+] unit-test
+
+[ "baz quux" ] [
+ <editor> "editor" set
+ "editor" get [
+ "foo bar\nbaz quux" "editor" get set-editor-string
+ "editor" get T{ one-line-elt } select-elt
+ "editor" get gadget-selection
+ ] with-grafted-gadget
+] unit-test
+
+[ ] [
+ <editor> "editor" set
+ "editor" get [
+ "foo bar\nbaz quux" "editor" get set-editor-string
+ 4 hand-click# set
+ "editor" get position-caret
+ ] with-grafted-gadget
+] unit-test
+
+[ "bar" ] [
+ <editor> "editor" set
+ "editor" get [
+ "bar\nbaz quux" "editor" get set-editor-string
+ { 0 3 } "editor" get editor-caret set-model
+ "editor" get select-word
+ "editor" get gadget-selection
+ ] with-grafted-gadget
+] unit-test
+
+\ <editor> must-infer
+
+"hello" <model> <field> "field" set
+
+"field" get [
+ [ "hello" ] [ "field" get field-model>> model-value ] unit-test
+] with-grafted-gadget
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays documents io kernel math models
+namespaces opengl opengl.gl sequences strings io.styles
+math.vectors sorting colors combinators assocs math.order
+ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
+ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
+ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures
+math.geometry.rect ;
+IN: ui.gadgets.editors
+
+TUPLE: editor < gadget
+font color caret-color selection-color
+caret mark
+focused? ;
+
+: <loc> ( -- loc ) { 0 0 } <model> ;
+
+: init-editor-locs ( editor -- editor )
+ <loc> >>caret
+ <loc> >>mark ; inline
+
+: editor-theme ( editor -- editor )
+ black >>color
+ red >>caret-color
+ selection-color >>selection-color
+ monospace-font >>font ; inline
+
+: new-editor ( class -- editor )
+ new-gadget
+ <document> >>model
+ init-editor-locs
+ editor-theme ; inline
+
+: <editor> ( -- editor )
+ editor new-editor ;
+
+: activate-editor-model ( editor model -- )
+ 2dup add-connection
+ dup activate-model
+ swap gadget-model add-loc ;
+
+: deactivate-editor-model ( editor model -- )
+ 2dup remove-connection
+ dup deactivate-model
+ swap gadget-model remove-loc ;
+
+M: editor graft*
+ dup
+ dup editor-caret activate-editor-model
+ dup editor-mark activate-editor-model ;
+
+M: editor ungraft*
+ dup
+ dup editor-caret deactivate-editor-model
+ dup editor-mark deactivate-editor-model ;
+
+: editor-caret* ( editor -- loc ) editor-caret model-value ;
+
+: editor-mark* ( editor -- loc ) editor-mark model-value ;
+
+: set-caret ( loc editor -- )
+ [ gadget-model validate-loc ] keep
+ editor-caret set-model ;
+
+: change-caret ( editor quot -- )
+ over >r >r dup editor-caret* swap gadget-model r> call r>
+ set-caret ; inline
+
+: mark>caret ( editor -- )
+ dup editor-caret* swap editor-mark set-model ;
+
+: change-caret&mark ( editor quot -- )
+ over >r change-caret r> mark>caret ; inline
+
+: editor-line ( n editor -- str ) control-value nth ;
+
+: editor-font* ( editor -- font ) editor-font open-font ;
+
+: line-height ( editor -- n )
+ editor-font* "" string-height ;
+
+: y>line ( y editor -- line# )
+ [ line-height / >fixnum ] keep gadget-model validate-line ;
+
+: point>loc ( point editor -- loc )
+ [
+ >r first2 r> tuck y>line dup ,
+ >r dup editor-font* r>
+ rot editor-line x>offset ,
+ ] { } make ;
+
+: clicked-loc ( editor -- loc )
+ [ hand-rel ] keep point>loc ;
+
+: click-loc ( editor model -- )
+ >r clicked-loc r> set-model ;
+
+: focus-editor ( editor -- )
+ t over set-editor-focused? relayout-1 ;
+
+: unfocus-editor ( editor -- )
+ f over set-editor-focused? relayout-1 ;
+
+: (offset>x) ( font col# str -- x )
+ swap head-slice string-width ;
+
+: offset>x ( col# line# editor -- x )
+ [ editor-line ] keep editor-font* -rot (offset>x) ;
+
+: loc>x ( loc editor -- x ) >r first2 swap r> offset>x ;
+
+: line>y ( lines# editor -- y )
+ line-height * ;
+
+: caret-loc ( editor -- loc )
+ [ editor-caret* ] keep 2dup loc>x
+ rot first rot line>y 2array ;
+
+: caret-dim ( editor -- dim )
+ line-height 0 swap 2array ;
+
+: scroll>caret ( editor -- )
+ dup gadget-graft-state second [
+ dup caret-loc over caret-dim { 1 0 } v+ <rect>
+ over scroll>rect
+ ] when drop ;
+
+: draw-caret ( -- )
+ editor get editor-focused? [
+ editor get
+ dup editor-caret-color set-color
+ dup caret-loc origin get v+
+ swap caret-dim over v+
+ [ { 0.5 -0.5 } v+ ] bi@ gl-line
+ ] when ;
+
+: line-translation ( n -- loc )
+ editor get line-height * 0.0 swap 2array ;
+
+: translate-lines ( n -- )
+ line-translation gl-translate ;
+
+: draw-line ( editor str -- )
+ >r editor-font r> { 0 0 } draw-string ;
+
+: first-visible-line ( editor -- n )
+ clip get rect-loc second origin get second -
+ swap y>line ;
+
+: last-visible-line ( editor -- n )
+ clip get rect-extent nip second origin get second -
+ swap y>line 1+ ;
+
+: with-editor ( editor quot -- )
+ [
+ swap
+ dup first-visible-line \ first-visible-line set
+ dup last-visible-line \ last-visible-line set
+ dup gadget-model document set
+ editor set
+ call
+ ] with-scope ; inline
+
+: visible-lines ( editor -- seq )
+ \ first-visible-line get
+ \ last-visible-line get
+ rot control-value <slice> ;
+
+: with-editor-translation ( n quot -- )
+ >r line-translation origin get v+ r> with-translation ;
+ inline
+
+: draw-lines ( -- )
+ \ first-visible-line get [
+ editor get dup editor-color set-color
+ dup visible-lines
+ [ draw-line 1 translate-lines ] with each
+ ] with-editor-translation ;
+
+: selection-start/end ( editor -- start end )
+ dup editor-mark* swap editor-caret* sort-pair ;
+
+: (draw-selection) ( x1 x2 -- )
+ 2dup = [ 2 + ] when
+ 0.0 swap editor get line-height glRectd ;
+
+: draw-selected-line ( start end n -- )
+ [ start/end-on-line ] keep tuck
+ >r >r editor get offset>x r> r>
+ editor get offset>x
+ (draw-selection) ;
+
+: draw-selection ( -- )
+ editor get editor-selection-color set-color
+ editor get selection-start/end
+ over first [
+ 2dup [
+ >r 2dup r> draw-selected-line
+ 1 translate-lines
+ ] each-line 2drop
+ ] with-editor-translation ;
+
+M: editor draw-gadget*
+ [ draw-selection draw-lines draw-caret ] with-editor ;
+
+M: editor pref-dim*
+ dup editor-font* swap control-value text-dim ;
+
+: contents-changed ( model editor -- )
+ swap
+ over caret>> [ over validate-loc ] (change-model)
+ over mark>> [ over validate-loc ] (change-model)
+ drop relayout ;
+
+: caret/mark-changed ( model editor -- )
+ nip [ relayout-1 ] [ scroll>caret ] bi ;
+
+M: editor model-changed
+ {
+ { [ 2dup model>> eq? ] [ contents-changed ] }
+ { [ 2dup caret>> eq? ] [ caret/mark-changed ] }
+ { [ 2dup mark>> eq? ] [ caret/mark-changed ] }
+ } cond ;
+
+M: editor gadget-selection?
+ selection-start/end = not ;
+
+M: editor gadget-selection
+ [ selection-start/end ] keep gadget-model doc-range ;
+
+: remove-selection ( editor -- )
+ [ selection-start/end ] keep gadget-model remove-doc-range ;
+
+M: editor user-input*
+ [ selection-start/end ] keep gadget-model set-doc-range t ;
+
+: editor-string ( editor -- string )
+ gadget-model doc-string ;
+
+: set-editor-string ( string editor -- )
+ gadget-model set-doc-string ;
+
+M: editor gadget-text* editor-string % ;
+
+: extend-selection ( editor -- )
+ dup request-focus dup editor-caret click-loc ;
+
+: mouse-elt ( -- element )
+ hand-click# get {
+ { 1 T{ one-char-elt } }
+ { 2 T{ one-word-elt } }
+ } at T{ one-line-elt } or ;
+
+: drag-direction? ( loc editor -- ? )
+ editor-mark* before? ;
+
+: drag-selection-caret ( loc editor element -- loc )
+ >r [ drag-direction? ] 2keep
+ gadget-model
+ r> prev/next-elt ? ;
+
+: drag-selection-mark ( loc editor element -- loc )
+ >r [ drag-direction? not ] 2keep
+ nip dup editor-mark* swap gadget-model
+ r> prev/next-elt ? ;
+
+: drag-caret&mark ( editor -- caret mark )
+ dup clicked-loc swap mouse-elt
+ [ drag-selection-caret ] 3keep
+ drag-selection-mark ;
+
+: drag-selection ( editor -- )
+ dup drag-caret&mark
+ pick editor-mark set-model
+ swap editor-caret set-model ;
+
+: editor-cut ( editor clipboard -- )
+ dupd gadget-copy remove-selection ;
+
+: delete/backspace ( elt editor quot -- )
+ over gadget-selection? [
+ drop nip remove-selection
+ ] [
+ over >r >r dup editor-caret* swap gadget-model
+ r> call r> gadget-model remove-doc-range
+ ] if ; inline
+
+: editor-delete ( editor elt -- )
+ swap [ over >r rot next-elt r> swap ] delete/backspace ;
+
+: editor-backspace ( editor elt -- )
+ swap [ over >r rot prev-elt r> ] delete/backspace ;
+
+: editor-select-prev ( editor elt -- )
+ swap [ rot prev-elt ] change-caret ;
+
+: editor-prev ( editor elt -- )
+ dupd editor-select-prev mark>caret ;
+
+: editor-select-next ( editor elt -- )
+ swap [ rot next-elt ] change-caret ;
+
+: editor-next ( editor elt -- )
+ dupd editor-select-next mark>caret ;
+
+: editor-select ( from to editor -- )
+ tuck editor-caret set-model editor-mark set-model ;
+
+: select-elt ( editor elt -- )
+ over >r
+ >r dup editor-caret* swap gadget-model r> prev/next-elt
+ r> editor-select ;
+
+: start-of-document ( editor -- ) T{ doc-elt } editor-prev ;
+
+: end-of-document ( editor -- ) T{ doc-elt } editor-next ;
+
+: position-caret ( editor -- )
+ mouse-elt dup T{ one-char-elt } =
+ [ drop dup extend-selection dup editor-mark click-loc ]
+ [ select-elt ] if ;
+
+: insert-newline ( editor -- ) "\n" swap user-input ;
+
+: delete-next-character ( editor -- )
+ T{ char-elt } editor-delete ;
+
+: delete-previous-character ( editor -- )
+ T{ char-elt } editor-backspace ;
+
+: delete-previous-word ( editor -- )
+ T{ word-elt } editor-delete ;
+
+: delete-next-word ( editor -- )
+ T{ word-elt } editor-backspace ;
+
+: delete-to-start-of-line ( editor -- )
+ T{ one-line-elt } editor-delete ;
+
+: delete-to-end-of-line ( editor -- )
+ T{ one-line-elt } editor-backspace ;
+
+editor "general" f {
+ { T{ key-down f f "DELETE" } delete-next-character }
+ { T{ key-down f { S+ } "DELETE" } delete-next-character }
+ { T{ key-down f f "BACKSPACE" } delete-previous-character }
+ { T{ key-down f { S+ } "BACKSPACE" } delete-previous-character }
+ { T{ key-down f { C+ } "DELETE" } delete-previous-word }
+ { T{ key-down f { C+ } "BACKSPACE" } delete-next-word }
+ { T{ key-down f { A+ } "DELETE" } delete-to-start-of-line }
+ { T{ key-down f { A+ } "BACKSPACE" } delete-to-end-of-line }
+} define-command-map
+
+: paste ( editor -- ) clipboard get paste-clipboard ;
+
+: paste-selection ( editor -- ) selection get paste-clipboard ;
+
+: cut ( editor -- ) clipboard get editor-cut ;
+
+editor "clipboard" f {
+ { T{ paste-action } paste }
+ { T{ button-up f f 2 } paste-selection }
+ { T{ copy-action } com-copy }
+ { T{ button-up } com-copy-selection }
+ { T{ cut-action } cut }
+} define-command-map
+
+: previous-character ( editor -- )
+ dup gadget-selection? [
+ dup selection-start/end drop
+ over set-caret mark>caret
+ ] [
+ T{ char-elt } editor-prev
+ ] if ;
+
+: next-character ( editor -- )
+ dup gadget-selection? [
+ dup selection-start/end nip
+ over set-caret mark>caret
+ ] [
+ T{ char-elt } editor-next
+ ] if ;
+
+: previous-line ( editor -- ) T{ line-elt } editor-prev ;
+
+: next-line ( editor -- ) T{ line-elt } editor-next ;
+
+: previous-word ( editor -- ) T{ word-elt } editor-prev ;
+
+: next-word ( editor -- ) T{ word-elt } editor-next ;
+
+: start-of-line ( editor -- ) T{ one-line-elt } editor-prev ;
+
+: end-of-line ( editor -- ) T{ one-line-elt } editor-next ;
+
+editor "caret-motion" f {
+ { T{ button-down } position-caret }
+ { T{ key-down f f "LEFT" } previous-character }
+ { T{ key-down f f "RIGHT" } next-character }
+ { T{ key-down f f "UP" } previous-line }
+ { T{ key-down f f "DOWN" } next-line }
+ { T{ key-down f { C+ } "LEFT" } previous-word }
+ { T{ key-down f { C+ } "RIGHT" } next-word }
+ { T{ key-down f f "HOME" } start-of-line }
+ { T{ key-down f f "END" } end-of-line }
+ { T{ key-down f { C+ } "HOME" } start-of-document }
+ { T{ key-down f { C+ } "END" } end-of-document }
+} define-command-map
+
+: select-all ( editor -- ) T{ doc-elt } select-elt ;
+
+: select-line ( editor -- ) T{ one-line-elt } select-elt ;
+
+: select-word ( editor -- ) T{ one-word-elt } select-elt ;
+
+: selected-word ( editor -- string )
+ dup gadget-selection?
+ [ dup select-word ] unless
+ gadget-selection ;
+
+: select-previous-character ( editor -- )
+ T{ char-elt } editor-select-prev ;
+
+: select-next-character ( editor -- )
+ T{ char-elt } editor-select-next ;
+
+: select-previous-line ( editor -- )
+ T{ line-elt } editor-select-prev ;
+
+: select-next-line ( editor -- )
+ T{ line-elt } editor-select-next ;
+
+: select-previous-word ( editor -- )
+ T{ word-elt } editor-select-prev ;
+
+: select-next-word ( editor -- )
+ T{ word-elt } editor-select-next ;
+
+: select-start-of-line ( editor -- )
+ T{ one-line-elt } editor-select-prev ;
+
+: select-end-of-line ( editor -- )
+ T{ one-line-elt } editor-select-next ;
+
+: select-start-of-document ( editor -- )
+ T{ doc-elt } editor-select-prev ;
+
+: select-end-of-document ( editor -- )
+ T{ doc-elt } editor-select-next ;
+
+editor "selection" f {
+ { T{ button-down f { S+ } } extend-selection }
+ { T{ drag } drag-selection }
+ { T{ gain-focus } focus-editor }
+ { T{ lose-focus } unfocus-editor }
+ { T{ delete-action } remove-selection }
+ { T{ select-all-action } select-all }
+ { T{ key-down f { C+ } "l" } select-line }
+ { T{ key-down f { S+ } "LEFT" } select-previous-character }
+ { T{ key-down f { S+ } "RIGHT" } select-next-character }
+ { T{ key-down f { S+ } "UP" } select-previous-line }
+ { T{ key-down f { S+ } "DOWN" } select-next-line }
+ { T{ key-down f { S+ C+ } "LEFT" } select-previous-word }
+ { T{ key-down f { S+ C+ } "RIGHT" } select-next-word }
+ { T{ key-down f { S+ } "HOME" } select-start-of-line }
+ { T{ key-down f { S+ } "END" } select-end-of-line }
+ { T{ key-down f { S+ C+ } "HOME" } select-start-of-document }
+ { T{ key-down f { S+ C+ } "END" } select-end-of-document }
+} define-command-map
+
+! Multi-line editors
+TUPLE: multiline-editor < editor ;
+
+: <multiline-editor> ( -- editor )
+ multiline-editor new-editor ;
+
+multiline-editor "general" f {
+ { T{ key-down f f "RET" } insert-newline }
+ { T{ key-down f { S+ } "RET" } insert-newline }
+ { T{ key-down f f "ENTER" } insert-newline }
+} define-command-map
+
+TUPLE: source-editor < multiline-editor ;
+
+: <source-editor> ( -- editor )
+ source-editor new-editor ;
+
+! Fields wrap an editor and edit an external model
+TUPLE: field < wrapper field-model editor ;
+
+: field-theme ( gadget -- gadget )
+ gray <solid> >>boundary ; inline
+
+: <field-border> ( gadget -- border )
+ 2 <border>
+ { 1 0 } >>fill
+ field-theme ;
+
+: <field> ( model -- gadget )
+ <editor> dup <field-border> field new-wrapper
+ swap >>editor
+ swap >>field-model ;
+
+M: field graft*
+ [ [ field-model>> model-value ] [ editor>> ] bi set-editor-string ]
+ [ dup editor>> model>> add-connection ]
+ bi ;
+
+M: field ungraft*
+ dup editor>> model>> remove-connection ;
+
+M: field model-changed
+ nip [ editor>> editor-string ] [ field-model>> ] bi set-model ;
--- /dev/null
+Editors edit a plain text document
--- /dev/null
+
+USING: kernel alien.c-types combinators sequences splitting grouping
+ opengl.gl ui.gadgets ui.render
+ math math.vectors accessors math.geometry.rect ;
+
+IN: ui.gadgets.frame-buffer
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: frame-buffer < gadget action pdim last-dim graft ungraft pixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-frame-buffer-pixels ( frame-buffer -- frame-buffer )
+ dup
+ rect-dim product "uint[4]" <c-array>
+ >>pixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: new-frame-buffer ( class -- gadget )
+ new-gadget
+ [ ] >>action
+ { 100 100 } >>pdim
+ [ ] >>graft
+ [ ] >>ungraft ;
+
+: <frame-buffer> ( -- frame-buffer ) frame-buffer new-frame-buffer ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: draw-pixels ( fb -- fb )
+ dup >r
+ dup >r
+ rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glDrawPixels
+ r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: read-pixels ( fb -- fb )
+ dup >r
+ dup >r
+ >r
+ 0 0 r> rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glReadPixels
+ r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: frame-buffer pref-dim* pdim>> ;
+M: frame-buffer graft* graft>> call ;
+M: frame-buffer ungraft* ungraft>> call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: copy-row ( old new -- )
+ 2dup min-length swap >r head-slice 0 r> copy ;
+
+! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
+! [ group ] 2bi@
+! [ copy-row ] 2each ;
+
+! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
+! [ 16 * group ] 2bi@
+! [ copy-row ] 2each ;
+
+: copy-pixels ( old-pixels old-width new-pixels new-width -- )
+ [ 16 * <sliced-groups> ] 2bi@
+ [ copy-row ] 2each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: frame-buffer layout* ( fb -- )
+ {
+ {
+ [ dup last-dim>> f = ]
+ [
+ init-frame-buffer-pixels
+ dup
+ rect-dim >>last-dim
+ drop
+ ]
+ }
+ {
+ [ dup [ rect-dim ] [ last-dim>> ] bi = not ]
+ [
+ dup [ pixels>> ] [ last-dim>> first ] bi
+
+ rot init-frame-buffer-pixels
+ dup rect-dim >>last-dim
+
+ [ pixels>> ] [ rect-dim first ] bi
+
+ copy-pixels
+ ]
+ }
+ { [ t ] [ drop ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: frame-buffer draw-gadget* ( fb -- )
+
+ dup rect-dim { 0 1 } v* first2 glRasterPos2i
+
+ draw-pixels
+
+ dup action>> call
+
+ glFlush
+
+ read-pixels
+
+ drop ;
+
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.syntax help.markup ui.gadgets kernel arrays
+quotations classes.tuple ui.gadgets.grids ;
+IN: ui.gadgets.frames
+
+ARTICLE: "ui-frame-layout" "Frame layouts"
+"Frames resemble " { $link "ui-grid-layout" } " except the size of grid is fixed at 3x3, and the center gadget fills up any available space. Because frames inherit from grids, grid layout words can be used to add and remove children."
+{ $subsection frame }
+"Creating empty frames:"
+{ $subsection <frame> }
+"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add } ":"
+{ $subsection @center }
+{ $subsection @left }
+{ $subsection @right }
+{ $subsection @top }
+{ $subsection @bottom }
+{ $subsection @top-left }
+{ $subsection @top-right }
+{ $subsection @bottom-left }
+{ $subsection @bottom-right } ;
+
+: $ui-frame-constant ( element -- )
+ drop
+ { $description "Symbolic constant for a common input to " { $link grid-add } "." } print-element ;
+
+HELP: @center $ui-frame-constant ;
+HELP: @left $ui-frame-constant ;
+HELP: @right $ui-frame-constant ;
+HELP: @top $ui-frame-constant ;
+HELP: @bottom $ui-frame-constant ;
+HELP: @top-left $ui-frame-constant ;
+HELP: @top-right $ui-frame-constant ;
+HELP: @bottom-left $ui-frame-constant ;
+HELP: @bottom-right $ui-frame-constant ;
+
+HELP: frame
+{ $class-description "A frame is a gadget which lays out its children in a 3x3 grid. If the frame is enlarged past its preferred size, the center gadget fills up available room."
+$nl
+"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add } " and " { $link grid-remove } "." } ;
+
+HELP: <frame>
+{ $values { "frame" frame } }
+{ $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." } ;
+
+{ grid frame } related-words
+
+ABOUT: "ui-frame-layout"
--- /dev/null
+IN: ui.gadgets.frames.tests
+USING: ui.gadgets.frames ui.gadgets tools.test ;
+
+[ ] [ <frame> layout ] unit-test
--- /dev/null
+! Copyright (C) 2005, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays generic kernel math namespaces sequences words
+splitting grouping math.vectors ui.gadgets.grids ui.gadgets
+math.geometry.rect ;
+IN: ui.gadgets.frames
+
+! A frame arranges gadgets in a 3x3 grid, where the center
+! gadgets gets left-over space.
+TUPLE: frame < grid ;
+
+: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
+
+: @center 1 1 ;
+: @left 0 1 ;
+: @right 2 1 ;
+: @top 1 0 ;
+: @bottom 1 2 ;
+
+: @top-left 0 0 ;
+: @top-right 2 0 ;
+: @bottom-left 0 2 ;
+: @bottom-right 2 2 ;
+
+: new-frame ( class -- frame )
+ <frame-grid> swap new-grid ; inline
+
+: <frame> ( -- frame )
+ frame new-frame ;
+
+: (fill-center) ( vec n -- )
+ over first pick third v+ [v-] 1 rot set-nth ;
+
+: fill-center ( horiz vert dim -- )
+ tuck (fill-center) (fill-center) ;
+
+M: frame layout*
+ dup compute-grid
+ [ rot rect-dim fill-center ] 3keep
+ grid-layout ;
--- /dev/null
+Frames position children around a center child which fills up any remaining space
--- /dev/null
+USING: help.markup help.syntax opengl kernel strings
+ classes.tuple classes quotations models math.geometry.rect ;
+IN: ui.gadgets
+
+HELP: gadget-child
+{ $values { "gadget" gadget } { "child" gadget } }
+{ $description "Outputs the first child of the gadget. Typically this word is used with gadgets which are known to have an only child." } ;
+
+HELP: nth-gadget
+{ $values { "n" "a non-negative integer" } { "gadget" gadget } { "child" gadget } }
+{ $description "Outputs the " { $snippet "n" } "th child of the gadget." }
+{ $errors "Throws an error if " { $snippet "n" } " is negative or greater than or equal to the number of children." } ;
+
+HELP: <gadget>
+{ $values { "gadget" "a new " { $link gadget } } }
+{ $description "Creates a new gadget." } ;
+
+HELP: relative-loc
+{ $values { "fromgadget" gadget } { "togadget" gadget } { "loc" "a pair of integers" } }
+{ $description
+ "Outputs the location of the top-left corner of " { $snippet "togadget" } " relative to the co-ordinate system of " { $snippet "fromgadget" } "."
+}
+{ $errors
+ "Throws an error if " { $snippet "togadget" } " is not contained in a child of " { $snippet "fromgadget" } "."
+} ;
+
+HELP: user-input*
+{ $values { "str" string } { "gadget" gadget } { "?" "a boolean" } }
+{ $contract "Handle free-form textual input while the gadget has keyboard focus." } ;
+
+HELP: children-on
+{ $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "gadget" gadget } { "seq" "a sequence of gadgets" } }
+{ $contract "Outputs a sequence of gadgets which potentially intersect a rectangle or contain a point in the co-ordinate system of the gadget." }
+{ $notes "This does not have to be an accurate intersection test, and simply returning " { $link gadget-children } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ;
+
+HELP: pick-up
+{ $values { "point" "a pair of integers" } { "gadget" gadget } { "child/f" "a " { $link gadget } " or " { $link f } } }
+{ $description "Outputs the child at a point in the gadget's co-ordinate system. This word recursively descends the gadget hierarchy, and so outputs the deepest child." } ;
+
+HELP: max-dim
+{ $values { "dims" "a sequence of pairs of integers" } { "dim" "a pair of integers" } }
+{ $description "Outputs the smallest dimensions of a rectangle which can fit all the dimensions in the sequence." } ;
+
+{ pref-dims max-dim dim-sum } related-words
+
+HELP: each-child
+{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( child -- )" } } }
+{ $description "Applies the quotation to each child of the gadget." } ;
+
+HELP: gadget-selection?
+{ $values { "gadget" gadget } { "?" "a boolean" } }
+{ $contract "Outputs if the gadget has an active text selection; if so, the selected text can be obtained with a call to " { $link gadget-selection } "." } ;
+
+HELP: gadget-selection
+{ $values { "gadget" gadget } { "string/f" "a " { $link string } " or " { $link f } } }
+{ $contract "Outputs the gadget's text selection, or " { $link f } " if nothing is selected." } ;
+
+HELP: relayout
+{ $values { "gadget" gadget } }
+{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout-1 } ", this relayouts all parents up to a gadget having " { $link gadget-root? } " set, so this word should be used when the gadget's dimensions have potentially changed." } ;
+
+HELP: relayout-1
+{ $values { "gadget" gadget } }
+{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout } ", this does not propagate requests up to the parent, and so this word should only be used when the gadget's internal layout or appearance has changed, but the dimensions have not." } ;
+
+{ relayout relayout-1 } related-words
+
+HELP: pref-dim*
+{ $values { "gadget" gadget } { "dim" "a pair of integers" } }
+{ $contract "Outputs the preferred dimensions of the gadget, possibly computing them from the preferred dimensions of the gadget's children." }
+{ $notes "User code should not call this word directly, instead call " { $link pref-dim } "." } ;
+
+HELP: pref-dim
+{ $values { "gadget" gadget } { "dim" "a pair of integers" } }
+{ $description "Outputs the preferred dimensions of the gadget. The value is cached between calls, and invalidated when the gadget needs to be relayout." } ;
+
+HELP: pref-dims
+{ $values { "gadgets" "a sequence of gadgets" } { "seq" "a sequence of pairs of integers" } }
+{ $description "Collects the preferred dimensions of every gadget in the sequence into a new sequence." } ;
+
+HELP: layout*
+{ $values { "gadget" gadget } }
+{ $contract "Lays out the children of the gadget according to the gadget's policy. The dimensions of the gadget are already set by the parent by the time this word is called." }
+{ $notes "User code should not call this word directly, instead call " { $link relayout } " and " { $link relayout-1 } "." } ;
+
+HELP: prefer
+{ $values { "gadget" gadget } }
+{ $contract "Resizes the gadget to assume its preferred dimensions." } ;
+
+HELP: dim-sum
+{ $values { "seq" "a sequence of pairs of integers" } { "dim" "a pair of integers" } }
+{ $description "Sums a sequence of dimensions." } ;
+
+HELP: layout
+{ $values { "gadget" gadget } }
+{ $description "Lays out the children of the gadget if the gadget needs to be relayout, and otherwise does nothing." }
+{ $notes "User code should not call this word directly, instead call " { $link relayout } " and " { $link relayout-1 } "." } ;
+
+{ pref-dim pref-dim* layout layout* } related-words
+
+HELP: graft*
+{ $values { "gadget" gadget } }
+{ $contract "Called to notify the gadget it has become visible on the screen. This should set up timers and threads, and acquire any resources used by the gadget." } ;
+
+{ graft graft* ungraft ungraft* } related-words
+
+HELP: ungraft*
+{ $values { "gadget" gadget } }
+{ $contract "Called to notify the gadget it is no longer visible on the screen. This should stop timers and threads, and release any resources used by the gadget." } ;
+
+HELP: graft
+{ $values { "gadget" gadget } }
+{ $description "Calls " { $link graft* } " on the gadget and all children." }
+{ $notes "This word should never be called directly." } ;
+
+HELP: ungraft
+{ $values { "gadget" gadget } }
+{ $description "If the gadget is grafted, calls " { $link ungraft* } " on the gadget and all children." }
+{ $notes "This word should never be called directly." } ;
+
+HELP: unparent
+{ $values { "gadget" gadget } }
+{ $description "Removes the gadget from its parent. This will relayout the parent." }
+{ $notes "This may result in " { $link ungraft* } " being called on the gadget and its children, if the gadget's parent is visible on the screen." } ;
+
+HELP: clear-gadget
+{ $values { "gadget" gadget } }
+{ $description "Removes all children from the gadget. This will relayout the gadget." }
+{ $notes "This may result in " { $link ungraft* } " being called on the children, if the gadget is visible on the screen." }
+{ $side-effects "gadget" } ;
+
+HELP: add-gadget
+{ $values { "gadget" gadget } { "parent" gadget } }
+{ $description "Adds a child gadget to a parent. If the gadget is contained in another gadget, " { $link unparent } " is called on the gadget first. The parent will be relayout." }
+{ $notes "Adding a gadget to a parent may result in " { $link graft* } " being called on the children, if the parent is visible on the screen." }
+{ $side-effects "parent" } ;
+
+HELP: add-gadgets
+{ $values { "seq" "a sequence of gadgets" } { "parent" gadget } }
+{ $description "Adds a sequence of gadgets to a parent. The parent will be relayout." }
+{ $notes "This may result in " { $link graft* } " being called on the children, if the parent is visible on the screen." }
+{ $side-effects "parent" } ;
+
+HELP: parents
+{ $values { "gadget" gadget } { "seq" "a sequence of gadgets" } }
+{ $description "Outputs a sequence of all parents of the gadget, with the first element being the gadget itself." } ;
+
+HELP: each-parent
+{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( gadget -- ? )" } } { "?" "a boolean" } }
+{ $description "Applies the quotation to every parent of the gadget, starting from the gadget itself, stopping if the quotation yields " { $link f } ". Outputs " { $link t } " if the iteration completed, and outputs " { $link f } " if it was stopped prematurely." } ;
+
+HELP: find-parent
+{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( gadget -- ? )" } } { "parent" gadget } }
+{ $description "Outputs the first parent of the gadget, starting from the gadget itself, for which the quotation outputs a true value, or " { $link f } " if the quotation outputs " { $link f } " for every parent." } ;
+
+HELP: screen-loc
+{ $values { "gadget" gadget } { "loc" "a pair of integers" } }
+{ $description "Outputs the location of the gadget relative to the top-left corner of the world containing the gadget. This word does not output a useful value if the gadget is not grafted." } ;
+
+HELP: child?
+{ $values { "parent" gadget } { "child" gadget } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "child" } " is contained inside " { $snippet "parent" } "." } ;
+
+HELP: focusable-child*
+{ $values { "gadget" gadget } { "child/t" "a " { $link gadget } " or " { $link t } } }
+{ $description "Outputs the child of the gadget which would prefer to receive keyboard focus, or " { $link t } " if the gadget itself should receive focus." }
+{ $examples "For example, if your gadget consists of an editor together with an output area whose contents react to changes in editor contents, then the " { $link focusable-child* } " method for your gadget class should return the editor, so that when the gadget is displayed in a window or passed to " { $link request-focus } ", the editor receives keyboard focus automatically." } ;
+
+HELP: focusable-child
+{ $values { "gadget" gadget } { "child" gadget } }
+{ $description "Outputs the child of the gadget which would prefer to receive keyboard focus." } ;
+
+{ control-value set-control-value gadget-model } related-words
+
+HELP: control-value
+{ $values { "control" gadget } { "value" object } }
+{ $description "Outputs the value of the control's model." } ;
+
+HELP: set-control-value
+{ $values { "value" object } { "control" gadget } }
+{ $description "Sets the value of the control's model." } ;
+
+ARTICLE: "ui-control-impl" "Implementing controls"
+"A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $link gadget-model } " slot set to a " { $link model } " instance."
+$nl
+"Some utility words useful in control implementations:"
+{ $subsection gadget-model }
+{ $subsection control-value }
+{ $subsection set-control-value }
+{ $see-also "models" } ;
--- /dev/null
+IN: ui.gadgets.tests
+USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds
+tools.test namespaces models kernel dlists deques math sets
+math.parser ui sequences hashtables assocs io arrays prettyprint
+io.streams.string math.geometry.rect ;
+
+[ { 300 300 } ]
+[
+ ! c contains b contains a
+ <gadget> "a" set
+ <gadget> "b" set
+ "a" get "b" get swap add-gadget drop
+ <gadget> "c" set
+ "b" get "c" get swap add-gadget drop
+
+ ! position a and b
+ { 100 200 } "a" get set-rect-loc
+ { 200 100 } "b" get set-rect-loc
+
+ ! give c a loc, it doesn't matter
+ { -1000 23 } "c" get set-rect-loc
+
+ ! what is the location of a inside c?
+ "a" get "c" get relative-loc
+] unit-test
+
+<gadget> "g1" set
+{ 10 10 } "g1" get set-rect-loc
+{ 30 30 } "g1" get set-rect-dim
+<gadget> "g2" set
+{ 20 20 } "g2" get set-rect-loc
+{ 50 500 } "g2" get set-rect-dim
+<gadget> "g3" set
+{ 100 200 } "g3" get set-rect-dim
+
+"g1" get "g2" get swap add-gadget drop
+"g2" get "g3" get swap add-gadget drop
+
+[ { 30 30 } ] [ "g1" get screen-loc ] unit-test
+[ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test
+[ { 30 30 } ] [ "g1" get screen-rect rect-dim ] unit-test
+[ { 20 20 } ] [ "g2" get screen-loc ] unit-test
+[ { 20 20 } ] [ "g2" get screen-rect rect-loc ] unit-test
+[ { 50 180 } ] [ "g2" get screen-rect rect-dim ] unit-test
+[ { 0 0 } ] [ "g3" get screen-loc ] unit-test
+[ { 0 0 } ] [ "g3" get screen-rect rect-loc ] unit-test
+[ { 100 200 } ] [ "g3" get screen-rect rect-dim ] unit-test
+
+<gadget> "g1" set
+{ 300 300 } "g1" get set-rect-dim
+<gadget> "g2" set
+"g2" get "g1" get swap add-gadget drop
+{ 20 20 } "g2" get set-rect-loc
+{ 20 20 } "g2" get set-rect-dim
+<gadget> "g3" set
+"g3" get "g1" get swap add-gadget drop
+{ 100 100 } "g3" get set-rect-loc
+{ 20 20 } "g3" get set-rect-dim
+
+[ t ] [ { 30 30 } "g2" get inside? ] unit-test
+
+[ t ] [ { 30 30 } "g1" get (pick-up) "g2" get eq? ] unit-test
+
+[ t ] [ { 30 30 } "g1" get pick-up "g2" get eq? ] unit-test
+
+[ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test
+
+<gadget> "g4" set
+"g4" get "g2" get swap add-gadget drop
+{ 5 5 } "g4" get set-rect-loc
+{ 1 1 } "g4" get set-rect-dim
+
+[ t ] [ { 25 25 } "g1" get pick-up "g4" get eq? ] unit-test
+
+TUPLE: mock-gadget < gadget graft-called ungraft-called ;
+
+: <mock-gadget> ( -- gadget )
+ mock-gadget new-gadget 0 >>graft-called 0 >>ungraft-called ;
+
+M: mock-gadget graft*
+ dup mock-gadget-graft-called 1+
+ swap set-mock-gadget-graft-called ;
+
+M: mock-gadget ungraft*
+ dup mock-gadget-ungraft-called 1+
+ swap set-mock-gadget-ungraft-called ;
+
+! We can't print to output-stream here because that might be a pane
+! stream, and our graft-queue rebinding here would be captured
+! by code adding children to the pane...
+[
+ <dlist> \ graft-queue [
+ [ ] [ <mock-gadget> dup queue-graft unqueue-graft ] unit-test
+ [ t ] [ graft-queue deque-empty? ] unit-test
+ ] with-variable
+
+ <dlist> \ graft-queue [
+ [ t ] [ graft-queue deque-empty? ] unit-test
+
+ <mock-gadget> "g" set
+ [ ] [ "g" get queue-graft ] unit-test
+ [ f ] [ graft-queue deque-empty? ] unit-test
+ [ { f t } ] [ "g" get gadget-graft-state ] unit-test
+ [ ] [ "g" get graft-later ] unit-test
+ [ { f t } ] [ "g" get gadget-graft-state ] unit-test
+ [ ] [ "g" get ungraft-later ] unit-test
+ [ { f f } ] [ "g" get gadget-graft-state ] unit-test
+ [ t ] [ graft-queue deque-empty? ] unit-test
+ [ ] [ "g" get ungraft-later ] unit-test
+ [ ] [ "g" get graft-later ] unit-test
+ [ ] [ notify-queued ] unit-test
+ [ { t t } ] [ "g" get gadget-graft-state ] unit-test
+ [ t ] [ graft-queue deque-empty? ] unit-test
+ [ ] [ "g" get graft-later ] unit-test
+ [ 1 ] [ "g" get mock-gadget-graft-called ] unit-test
+ [ ] [ "g" get ungraft-later ] unit-test
+ [ { t f } ] [ "g" get gadget-graft-state ] unit-test
+ [ ] [ notify-queued ] unit-test
+ [ 1 ] [ "g" get mock-gadget-ungraft-called ] unit-test
+ [ { f f } ] [ "g" get gadget-graft-state ] unit-test
+ ] with-variable
+
+ : add-some-children
+ 3 [
+ <mock-gadget> over <model> over set-gadget-model
+ dup "g" get swap add-gadget drop
+ swap 1+ number>string set
+ ] each ;
+
+ : status-flags
+ { "g" "1" "2" "3" } [ get gadget-graft-state ] map prune ;
+
+ : notify-combo ( ? ? -- )
+ nl "===== Combo: " write 2dup 2array . nl
+ <dlist> \ graft-queue [
+ <mock-gadget> "g" set
+ [ ] [ add-some-children ] unit-test
+ [ V{ { f f } } ] [ status-flags ] unit-test
+ [ ] [ "g" get graft ] unit-test
+ [ V{ { f t } } ] [ status-flags ] unit-test
+ dup [ [ ] [ notify-queued ] unit-test ] when
+ [ ] [ "g" get clear-gadget ] unit-test
+ [ [ 1 ] [ graft-queue dlist-length ] unit-test ] unless
+ [ [ ] [ notify-queued ] unit-test ] when
+ [ ] [ add-some-children ] unit-test
+ [ { f t } ] [ "1" get gadget-graft-state ] unit-test
+ [ { f t } ] [ "2" get gadget-graft-state ] unit-test
+ [ { f t } ] [ "3" get gadget-graft-state ] unit-test
+ [ ] [ graft-queue [ "x" print notify ] slurp-deque ] unit-test
+ [ ] [ notify-queued ] unit-test
+ [ V{ { t t } } ] [ status-flags ] unit-test
+ ] with-variable ;
+
+ { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
+] with-string-writer print
+
+\ <gadget> must-infer
+\ unparent must-infer
+\ add-gadget must-infer
+\ add-gadgets must-infer
+\ clear-gadget must-infer
+
+\ relayout must-infer
+\ relayout-1 must-infer
+\ pref-dim must-infer
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays hashtables kernel models math namespaces
+ sequences quotations math.vectors combinators sorting
+ binary-search vectors dlists deques models threads
+ concurrency.flags math.order math.geometry.rect ;
+
+IN: ui.gadgets
+
+SYMBOL: ui-notify-flag
+
+: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
+
+TUPLE: gadget < rect
+ pref-dim parent children orientation focus
+ visible? root? clipped? layout-state graft-state graft-node
+ interior boundary
+ model ;
+
+M: gadget equal? 2drop f ;
+
+M: gadget hashcode* drop gadget hashcode* ;
+
+M: gadget model-changed 2drop ;
+
+: gadget-child ( gadget -- child ) children>> first ;
+
+: nth-gadget ( n gadget -- child ) children>> nth ;
+
+: init-gadget ( gadget -- gadget )
+ init-rect
+ { 0 1 } >>orientation
+ t >>visible?
+ { f f } >>graft-state ; inline
+
+: new-gadget ( class -- gadget ) new init-gadget ; inline
+
+: <gadget> ( -- gadget )
+ gadget new-gadget ;
+
+: activate-control ( gadget -- )
+ dup model>> dup [
+ 2dup add-connection
+ swap model-changed
+ ] [
+ 2drop
+ ] if ;
+
+: deactivate-control ( gadget -- )
+ dup model>> dup [ 2dup remove-connection ] when 2drop ;
+
+: control-value ( control -- value )
+ model>> model-value ;
+
+: set-control-value ( value control -- )
+ model>> set-model ;
+
+: relative-loc ( fromgadget togadget -- loc )
+ 2dup eq? [
+ 2drop { 0 0 }
+ ] [
+ over rect-loc >r
+ >r parent>> r> relative-loc
+ r> v+
+ ] if ;
+
+GENERIC: user-input* ( str gadget -- ? )
+
+M: gadget user-input* 2drop t ;
+
+GENERIC: children-on ( rect/point gadget -- seq )
+
+M: gadget children-on nip children>> ;
+
+: ((fast-children-on)) ( gadget dim axis -- <=> )
+ [ swap loc>> v- ] dip v. 0 <=> ;
+
+: (fast-children-on) ( dim axis children -- i )
+ -rot [ ((fast-children-on)) ] 2curry search drop ;
+
+: fast-children-on ( rect axis children -- from to )
+ [ [ rect-loc ] 2dip (fast-children-on) 0 or ]
+ [ [ rect-bounds v+ ] 2dip (fast-children-on) ?1+ ]
+ 3bi ;
+
+: inside? ( bounds gadget -- ? )
+ dup visible?>> [ intersects? ] [ 2drop f ] if ;
+
+: (pick-up) ( point gadget -- gadget )
+ dupd children-on [ inside? ] with find-last nip ;
+
+: pick-up ( point gadget -- child/f )
+ 2dup (pick-up) dup
+ [ nip [ rect-loc v- ] keep pick-up ] [ rot 2drop ] if ;
+
+: max-dim ( dims -- dim ) { 0 0 } [ vmax ] reduce ;
+
+: dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
+
+: orient ( gadget seq1 seq2 -- seq )
+ >r >r orientation>> r> r> [ pick set-axis ] 2map nip ;
+
+: each-child ( gadget quot -- )
+ >r children>> r> each ; inline
+
+! Selection protocol
+GENERIC: gadget-selection? ( gadget -- ? )
+
+M: gadget gadget-selection? drop f ;
+
+GENERIC: gadget-selection ( gadget -- string/f )
+
+M: gadget gadget-selection drop f ;
+
+! Text protocol
+GENERIC: gadget-text* ( gadget -- )
+
+GENERIC: gadget-text-separator ( gadget -- str )
+
+M: gadget gadget-text-separator
+ orientation>> { 0 1 } = "\n" "" ? ;
+
+: gadget-seq-text ( seq gadget -- )
+ gadget-text-separator swap
+ [ dup % ] [ gadget-text* ] interleave drop ;
+
+M: gadget gadget-text*
+ dup children>> swap gadget-seq-text ;
+
+M: array gadget-text*
+ [ gadget-text* ] each ;
+
+: gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
+
+: invalidate ( gadget -- )
+ \ invalidate swap (>>layout-state) ;
+
+: forget-pref-dim ( gadget -- ) f swap (>>pref-dim) ;
+
+: layout-queue ( -- queue ) \ layout-queue get ;
+
+: layout-later ( gadget -- )
+ #! When unit testing gadgets without the UI running, the
+ #! invalid queue is not initialized and we simply ignore
+ #! invalidation requests.
+ layout-queue [ push-front notify-ui-thread ] [ drop ] if* ;
+
+DEFER: relayout
+
+: invalidate* ( gadget -- )
+ \ invalidate* over (>>layout-state)
+ dup forget-pref-dim
+ dup gadget-root?
+ [ layout-later ] [ parent>> [ relayout ] when* ] if ;
+
+: relayout ( gadget -- )
+ dup layout-state>> \ invalidate* eq?
+ [ drop ] [ invalidate* ] if ;
+
+: relayout-1 ( gadget -- )
+ dup layout-state>>
+ [ drop ] [ dup invalidate layout-later ] if ;
+
+: show-gadget ( gadget -- ) t swap (>>visible?) ;
+
+: hide-gadget ( gadget -- ) f swap (>>visible?) ;
+
+DEFER: in-layout?
+
+: do-invalidate ( gadget -- gadget )
+ in-layout? get [ dup invalidate ] [ dup invalidate* ] if ;
+
+M: gadget (>>dim) ( dim gadget -- )
+ 2dup dim>> =
+ [ 2drop ]
+ [ tuck call-next-method do-invalidate drop ]
+ if ;
+
+GENERIC: pref-dim* ( gadget -- dim )
+
+: ?set-gadget-pref-dim ( dim gadget -- )
+ dup layout-state>>
+ [ 2drop ] [ (>>pref-dim) ] if ;
+
+: pref-dim ( gadget -- dim )
+ dup pref-dim>> [ ] [
+ [ pref-dim* dup ] keep ?set-gadget-pref-dim
+ ] ?if ;
+
+: pref-dims ( gadgets -- seq ) [ pref-dim ] map ;
+
+M: gadget pref-dim* rect-dim ;
+
+GENERIC: layout* ( gadget -- )
+
+M: gadget layout* drop ;
+
+: prefer ( gadget -- ) dup pref-dim swap (>>dim) ;
+
+: validate ( gadget -- ) f swap (>>layout-state) ;
+
+: layout ( gadget -- )
+ dup layout-state>> [
+ dup validate
+ dup layout*
+ dup [ layout ] each-child
+ ] when drop ;
+
+: graft-queue ( -- dlist ) \ graft-queue get ;
+
+: unqueue-graft ( gadget -- )
+ [ graft-node>> graft-queue delete-node ]
+ [ [ first { t t } { f f } ? ] change-graft-state drop ] bi ;
+
+: (queue-graft) ( gadget flags -- )
+ >>graft-state
+ dup graft-queue push-front* >>graft-node drop
+ notify-ui-thread ;
+
+: queue-graft ( gadget -- )
+ { f t } (queue-graft) ;
+
+: queue-ungraft ( gadget -- )
+ { t f } (queue-graft) ;
+
+: graft-later ( gadget -- )
+ dup graft-state>> {
+ { { f t } [ drop ] }
+ { { t t } [ drop ] }
+ { { t f } [ unqueue-graft ] }
+ { { f f } [ queue-graft ] }
+ } case ;
+
+: ungraft-later ( gadget -- )
+ dup graft-state>> {
+ { { f f } [ drop ] }
+ { { t f } [ drop ] }
+ { { f t } [ unqueue-graft ] }
+ { { t t } [ queue-ungraft ] }
+ } case ;
+
+GENERIC: graft* ( gadget -- )
+
+M: gadget graft* drop ;
+
+: graft ( gadget -- )
+ dup graft-later [ graft ] each-child ;
+
+GENERIC: ungraft* ( gadget -- )
+
+M: gadget ungraft* drop ;
+
+: ungraft ( gadget -- )
+ dup [ ungraft ] each-child ungraft-later ;
+
+: (unparent) ( gadget -- )
+ dup ungraft
+ dup forget-pref-dim
+ f swap (>>parent) ;
+
+: unfocus-gadget ( child gadget -- )
+ tuck focus>> eq?
+ [ f swap (>>focus) ] [ drop ] if ;
+
+SYMBOL: in-layout?
+
+: not-in-layout ( -- )
+ in-layout? get
+ [ "Cannot add/remove gadgets in layout*" throw ] when ;
+
+: unparent ( gadget -- )
+ not-in-layout
+ [
+ dup parent>> dup [
+ over (unparent)
+ [ unfocus-gadget ] 2keep
+ [ children>> delete ] keep
+ relayout
+ ] [
+ 2drop
+ ] if
+ ] when* ;
+
+: (clear-gadget) ( gadget -- )
+ dup [ (unparent) ] each-child
+ f over (>>focus)
+ f swap (>>children) ;
+
+: clear-gadget ( gadget -- )
+ not-in-layout
+ dup (clear-gadget) relayout ;
+
+: ((add-gadget)) ( parent child -- parent )
+ over children>> ?push >>children ;
+
+: (add-gadget) ( parent child -- parent )
+ dup unparent
+ over >>parent
+ tuck ((add-gadget))
+ tuck graft-state>> second
+ [ graft ]
+ [ drop ]
+ if ;
+
+: add-gadget ( parent child -- parent )
+ not-in-layout
+ (add-gadget)
+ dup relayout ;
+
+: add-gadgets ( parent children -- parent )
+ not-in-layout
+ [ (add-gadget) ] each
+ dup relayout ;
+
+: parents ( gadget -- seq )
+ [ parent>> ] follow ;
+
+: each-parent ( gadget quot -- ? )
+ >r parents r> all? ; inline
+
+: find-parent ( gadget quot -- parent )
+ >r parents r> find nip ; inline
+
+: screen-loc ( gadget -- loc )
+ parents { 0 0 } [ rect-loc v+ ] reduce ;
+
+: (screen-rect) ( gadget -- loc ext )
+ dup parent>> [
+ >r rect-extent r> (screen-rect)
+ >r tuck v+ r> vmin >r v+ r>
+ ] [
+ rect-extent
+ ] if* ;
+
+: screen-rect ( gadget -- rect )
+ (screen-rect) <extent-rect> ;
+
+: child? ( parent child -- ? )
+ {
+ { [ 2dup eq? ] [ 2drop t ] }
+ { [ dup not ] [ 2drop f ] }
+ [ parent>> child? ]
+ } cond ;
+
+GENERIC: focusable-child* ( gadget -- child/t )
+
+M: gadget focusable-child* drop t ;
+
+: focusable-child ( gadget -- child )
+ dup focusable-child*
+ dup t eq? [ drop ] [ nip focusable-child ] if ;
+
+GENERIC: request-focus-on ( child gadget -- )
+
+M: gadget request-focus-on parent>> request-focus-on ;
+
+M: f request-focus-on 2drop ;
+
+: request-focus ( gadget -- )
+ [ focusable-child ] keep request-focus-on ;
+
+: focus-path ( world -- seq )
+ [ focus>> ] follow ;
+
+! Deprecated
+
+: construct-gadget ( class -- tuple )
+ >r <gadget> { set-delegate } r> construct ; inline
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets help.markup help.syntax ui.gadgets.grids
+ui.render ;
+IN: ui.gadgets.grid-lines
+
+HELP: grid-lines
+{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $link grid-lines-color } " slot." } ;
--- /dev/null
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math namespaces opengl opengl.gl sequences
+math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
+IN: ui.gadgets.grid-lines
+
+TUPLE: grid-lines color ;
+
+C: <grid-lines> grid-lines
+
+SYMBOL: grid-dim
+
+: half-gap grid get grid-gap [ 2/ ] map ; inline
+
+: grid-line-from/to ( orientation point -- from to )
+ half-gap v-
+ [ half-gap spin set-axis ] 2keep
+ grid-dim get spin set-axis ;
+
+: draw-grid-lines ( gaps orientation -- )
+ grid get rot grid-positions grid get rect-dim suffix [
+ grid-line-from/to gl-line
+ ] with each ;
+
+M: grid-lines draw-boundary
+ origin get [
+ -0.5 -0.5 0.0 glTranslated
+ grid-lines-color set-color [
+ dup grid set
+ dup rect-dim half-gap v- grid-dim set
+ compute-grid
+ { 0 1 } draw-grid-lines
+ { 1 0 } draw-grid-lines
+ ] with-scope
+ ] with-translation ;
--- /dev/null
+Grid lines visibly separate children of grids and frames
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets help.markup help.syntax arrays ;
+IN: ui.gadgets.grids
+
+ARTICLE: "ui-grid-layout" "Grid layouts"
+"Grid gadgets layout their children in a rectangular grid."
+{ $subsection grid }
+"Creating grids from a fixed set of gadgets:"
+{ $subsection <grid> }
+"Managing chidren:"
+{ $subsection grid-add }
+{ $subsection grid-remove }
+{ $subsection grid-child } ;
+
+HELP: grid
+{ $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height."
+$nl
+"The " { $link grid-gap } " slot stores a pair of integers, the horizontal and vertical gap between children, respectively."
+$nl
+"The " { $link grid-fill? } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
+$nl
+"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "."
+$nl
+"The " { $link add-gadget } ", " { $link unparent } " and " { $link clear-gadget } " words should not be used to manage child gadgets of grids." } ;
+
+HELP: <grid>
+{ $values { "children" "a sequence of sequences of gadgets" } { "grid" "a new " { $link grid } } }
+{ $description "Creates a new " { $link grid } " gadget with the given children." } ;
+
+HELP: grid-child
+{ $values { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } { "gadget" gadget } }
+{ $description "Outputs the child gadget at the " { $snippet "i" } "," { $snippet "j" } "th position of the grid." }
+{ $errors "Throws an error if the indices are out of bounds." } ;
+
+HELP: grid-add
+{ $values { "gadget" gadget } { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
+{ $description "Adds a child gadget at the specified location." }
+{ $side-effects "grid" } ;
+
+HELP: grid-remove
+{ $values { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
+{ $description "Removes a child gadget from the specified location." }
+{ $side-effects "grid" } ;
+
+ABOUT: "ui-grid-layout"
--- /dev/null
+USING: ui.gadgets ui.gadgets.grids tools.test kernel arrays
+namespaces math.geometry.rect ;
+IN: ui.gadgets.grids.tests
+
+[ { 0 0 } ] [ { } <grid> pref-dim ] unit-test
+
+: 100x100 <gadget> { 100 100 } over set-rect-dim ;
+
+[ { 100 100 } ] [
+ 100x100
+ 1array 1array <grid> pref-dim
+] unit-test
+
+[ { 100 100 } ] [
+ 100x100
+ 1array 1array <grid> pref-dim
+] unit-test
+
+[ { 200 100 } ] [
+ 100x100
+ 100x100
+ 2array 1array <grid> pref-dim
+] unit-test
+
+[ { 100 200 } ] [
+ 100x100
+ 100x100
+ [ 1array ] bi@ 2array <grid> pref-dim
+] unit-test
+
+[ ] [
+ 100x100
+ 100x100
+ [ 1array ] bi@ 2array <grid> layout
+] unit-test
+
+[ { 230 120 } { 100 100 } { 100 100 } ] [
+ 100x100 dup "a" set
+ 100x100 dup "b" set
+ 2array 1array <grid>
+ { 10 10 } over set-grid-gap
+ dup prefer
+ dup layout
+ rect-dim
+ "a" get rect-dim
+ "b" get rect-dim
+] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math namespaces sequences words io
+io.streams.string math.vectors ui.gadgets columns accessors
+math.geometry.rect ;
+IN: ui.gadgets.grids
+
+TUPLE: grid < gadget
+grid
+{ gap initial: { 0 0 } }
+{ fill? initial: t } ;
+
+: new-grid ( children class -- grid )
+ new-gadget
+ [ (>>grid) ] [ >r concat r> swap add-gadgets drop ] [ nip ] 2tri ;
+ inline
+
+: <grid> ( children -- grid )
+ grid new-grid ;
+
+: grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
+
+: grid-add ( grid child i j -- grid )
+ >r >r dupd swap r> r>
+ >r >r 2dup swap add-gadget drop r> r>
+ 3dup grid-child unparent rot grid>> nth set-nth ;
+
+: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add ;
+
+: pref-dim-grid ( grid -- dims )
+ grid>> [ [ pref-dim ] map ] map ;
+
+: (compute-grid) ( grid -- seq ) [ max-dim ] map ;
+
+: compute-grid ( grid -- horiz vert )
+ pref-dim-grid dup flip (compute-grid) swap (compute-grid) ;
+
+: (pair-up) ( horiz vert -- dim )
+ >r first r> second 2array ;
+
+: pair-up ( horiz vert -- dims )
+ [ [ (pair-up) ] curry map ] with map ;
+
+: add-gaps ( gap seq -- newseq )
+ [ v+ ] with map ;
+
+: gap-sum ( gap seq -- newseq )
+ dupd add-gaps dim-sum v+ ;
+
+M: grid pref-dim*
+ dup grid-gap swap compute-grid >r over r>
+ gap-sum >r gap-sum r> (pair-up) ;
+
+: do-grid ( dims grid quot -- )
+ -rot grid>>
+ [ [ pick call ] 2each ] 2each
+ drop ; inline
+
+: grid-positions ( grid dims -- locs )
+ >r grid-gap dup r> add-gaps swap [ v+ ] accumulate nip ;
+
+: position-grid ( grid horiz vert -- )
+ pick >r
+ >r over r> grid-positions >r grid-positions r>
+ pair-up r> [ set-rect-loc ] do-grid ;
+
+: resize-grid ( grid horiz vert -- )
+ pick grid-fill? [
+ pair-up swap [ (>>dim) ] do-grid
+ ] [
+ 2drop grid>> [ [ prefer ] each ] each
+ ] if ;
+
+: grid-layout ( grid horiz vert -- )
+ [ position-grid ] 3keep resize-grid ;
+
+M: grid layout* dup compute-grid grid-layout ;
+
+M: grid children-on ( rect gadget -- seq )
+ dup gadget-children empty? [
+ 2drop f
+ ] [
+ { 0 1 } swap grid>>
+ [ 0 <column> fast-children-on ] keep
+ <slice> concat
+ ] if ;
+
+M: grid gadget-text*
+ grid>>
+ [ [ gadget-text ] map ] map format-table
+ [ CHAR: \n , ] [ % ] interleave ;
--- /dev/null
+Grids arrange children in a variable-size grid
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel assocs ui.gestures ui.gadgets.wrappers accessors ;
+
+IN: ui.gadgets.handler
+
+TUPLE: handler < wrapper table ;
+
+: <handler> ( child -- handler ) handler new-wrapper ;
+
+M: handler handle-gesture* ( gadget gesture delegate -- ? )
+ table>> at dup [ call f ] [ 2drop t ] if ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets help.markup help.syntax ui.gadgets.packs ;
+IN: ui.gadgets.incremental
+
+HELP: incremental
+{ $class-description "Incremental layout gadgets inherit from " { $link pack } " and implement an optimization where the relayout operation after adding a child to be done in constant time."
+$nl
+"Incremental layout gadgets are created by calling " { $link <incremental> } "."
+$nl
+"Children are managed with the " { $link add-incremental } " and " { $link clear-incremental } " words."
+$nl
+"Not every " { $link pack } " can use incremental layout, since incremental layout does not support non-default values for " { $link pack-align } ", " { $link pack-fill } ", and " { $link pack-gap } "." } ;
+
+HELP: <incremental>
+{ $values { "pack" pack } { "incremental" "a new instance of " { $link incremental } } }
+{ $description "Creates a new incremental layout gadget delegating to " { $snippet "pack" } "." } ;
+
+{ <incremental> add-incremental clear-incremental } related-words
+
+HELP: add-incremental
+{ $values { "gadget" gadget } { "incremental" incremental } }
+{ $description "Adds the gadget to the incremental layout and performs relayout immediately in constant time." }
+{ $side-effects "incremental" } ;
+
+HELP: clear-incremental
+{ $values { "incremental" incremental } }
+{ $description "Removes all gadgets from the incremental layout and performs relayout immediately in constant time." }
+{ $side-effects "incremental" } ;
+
+ARTICLE: "ui-incremental-layout" "Incremental layouts"
+"Incremental layout gadgets are like " { $link "ui-pack-layout" } " except the relayout operation after adding a new child can be done in constant time."
+$nl
+"With all layouts, relayout requests from consecutive additions and removals are of children are coalesced and result in only one relayout operation being performed, however the run time of the relayout operation itself depends on the number of children."
+$nl
+"Incremental layout is used by " { $link "ui.gadgets.panes" } " to ensure that new lines of output does not take longer to display when the pane already has previous output."
+$nl
+"Incremental layouts are not a general replacement for " { $link "ui-pack-layout" } " and there are some limitations to be aware of."
+{ $subsection incremental }
+{ $subsection <incremental> }
+"Children are added and removed with a special set of words which perform necessary relayout immediately:"
+{ $subsection add-incremental }
+{ $subsection clear-incremental }
+"Calling " { $link unparent } " to remove a child of an incremental layout is permitted, however the relayout following the removal will not be performed in constant time, because all gadgets following the removed gadget need to be moved." ;
+
+ABOUT: "ui-incremental-layout"
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io kernel math namespaces math.vectors ui.gadgets
+ui.gadgets.packs accessors math.geometry.rect ;
+IN: ui.gadgets.incremental
+
+! Incremental layout allows adding lines to panes to be O(1).
+! Note that incremental packs are distinct from ordinary packs
+! defined in layouts.factor, since you don't want all packs to
+! be incremental. In particular, incremental packs do not
+! support non-default values for pack-align, pack-fill and
+! pack-gap.
+
+! The cursor is the current size of the incremental pack.
+! New gadgets are added at
+! incremental-cursor gadget-orientation v*
+
+TUPLE: incremental < pack cursor ;
+
+: <incremental> ( -- incremental )
+ incremental new-gadget
+ { 0 1 } >>orientation
+ { 0 0 } >>cursor ;
+
+M: incremental pref-dim*
+ dup gadget-layout-state [
+ dup call-next-method over set-incremental-cursor
+ ] when incremental-cursor ;
+
+: next-cursor ( gadget incremental -- cursor )
+ [
+ swap rect-dim swap incremental-cursor
+ 2dup v+ >r vmax r>
+ ] keep gadget-orientation set-axis ;
+
+: update-cursor ( gadget incremental -- )
+ [ next-cursor ] keep set-incremental-cursor ;
+
+: incremental-loc ( gadget incremental -- )
+ dup incremental-cursor swap gadget-orientation v*
+ swap set-rect-loc ;
+
+: prefer-incremental ( gadget -- )
+ dup forget-pref-dim dup pref-dim swap set-rect-dim ;
+
+: add-incremental ( gadget incremental -- )
+ not-in-layout
+ 2dup swap (add-gadget) drop
+ over prefer-incremental
+ over layout-later
+ 2dup incremental-loc
+ tuck update-cursor
+ dup prefer-incremental
+ gadget-parent [ invalidate* ] when* ;
+
+: clear-incremental ( incremental -- )
+ not-in-layout
+ dup (clear-gadget)
+ dup forget-pref-dim
+ { 0 0 } over set-incremental-cursor
+ gadget-parent [ relayout ] when* ;
--- /dev/null
+Children can be added to incremental layouts in constant time
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets help.markup help.syntax strings models
+ui.gadgets.panes ;
+IN: ui.gadgets.labelled
+
+HELP: labelled-gadget
+{ $class-description "A labelled gadget can be created by calling " { $link <labelled-gadget> } "." } ;
+
+HELP: <labelled-gadget>
+{ $values { "gadget" gadget } { "title" string } { "newgadget" "a new " { $link <labelled-gadget> } } }
+{ $description "Creates a new " { $link labelled-gadget } " display " { $snippet "gadget" } " with " { $snippet "title" } " on top." } ;
+
+HELP: closable-gadget
+{ $class-description "A closable gadget displays a title bar with a close box on top of another gadget. Clicking the close box invokes a quotation. Closable gadgets are created by calling " { $link <closable-gadget> } "." } ;
+
+HELP: <closable-gadget>
+{ $values { "gadget" gadget } { "title" string } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } }
+{ $description "Creates a new " { $link closable-gadget } ". Clicking the close box calls " { $snippet "quot" } "." }
+{ $notes "The quotation can find the " { $link closable-gadget } " instance, or any other parent gadget by calling " { $link find-parent } " with the gadget it receives on the stack." } ;
+
+HELP: <labelled-pane>
+{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "scrolls?" "a boolean" } { "title" string } { "gadget" "a new " { $link gadget } } }
+{ $description "Creates a new control delegating to a " { $link pane } ", and wraps it in a " { $link labelled-gadget } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
+
+{ <labelled-pane> <pane-control> } related-words
+
+ARTICLE: "ui.gadgets.labelled" "Labelled gadgets"
+"It is possible to create a labelled border around a child gadget:"
+{ $subsection labelled-gadget }
+{ $subsection <labelled-gadget> }
+"Or a labelled border with a close box:"
+{ $subsection closable-gadget }
+{ $subsection <closable-gadget> } ;
+
+ABOUT: "ui.gadgets.labelled"
--- /dev/null
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays ui.gadgets.buttons ui.gadgets.borders
+ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
+ui.gadgets.tracks ui.gadgets.theme ui.gadgets.frames
+ui.gadgets.grids io kernel math models namespaces prettyprint
+sequences sequences words classes.tuple ui.gadgets ui.render
+colors accessors ;
+IN: ui.gadgets.labelled
+
+TUPLE: labelled-gadget < track content ;
+
+: <labelled-gadget> ( gadget title -- newgadget )
+ { 0 1 } labelled-gadget new-track
+ swap <label> reverse-video-theme f track-add
+ swap >>content
+ dup content>> 1 track-add ;
+
+M: labelled-gadget focusable-child* labelled-gadget-content ;
+
+: <labelled-scroller> ( gadget title -- gadget )
+ >r <scroller> r> <labelled-gadget> ;
+
+: <labelled-pane> ( model quot scrolls? title -- gadget )
+ >r >r <pane-control> r> over set-pane-scrolls? r>
+ <labelled-scroller> ;
+
+: <close-box> ( quot -- button/f )
+ gray close-box <polygon-gadget> swap <bevel-button> ;
+
+: title-theme ( gadget -- )
+ { 1 0 } over set-gadget-orientation
+ T{ gradient f {
+ T{ rgba f 0.65 0.65 1.0 1.0 }
+ T{ rgba f 0.65 0.45 1.0 1.0 }
+ } } swap set-gadget-interior ;
+
+: <title-label> ( text -- label ) <label> dup title-theme ;
+
+: <title-bar> ( title quot -- gadget )
+ <frame>
+ swap dup [ <close-box> @left grid-add ] [ drop ] if
+ swap <title-label> @center grid-add ;
+
+TUPLE: closable-gadget < frame content ;
+
+: find-closable-gadget ( parent -- child )
+ [ [ closable-gadget? ] is? ] find-parent ;
+
+: <closable-gadget> ( gadget title quot -- gadget )
+ closable-gadget new-frame
+ -rot <title-bar> @top grid-add
+ swap >>content
+ dup content>> @center grid-add ;
+
+M: closable-gadget focusable-child* closable-gadget-content ;
--- /dev/null
+Labelled gadgets display a border with a text label surrounding a child
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax strings ui.gadgets models ;
+IN: ui.gadgets.labels
+
+HELP: label
+{ $class-description "A label displays a piece of text, either a single line string or an array of line strings. Labels are created by calling " { $link <label> } "." } ;
+
+HELP: <label>
+{ $values { "string" string } { "label" "a new " { $link label } } }
+{ $description "Creates a new " { $link label } " gadget. The string is permitted to contain line breaks." } ;
+
+HELP: label-string
+{ $values { "label" label } { "string" string } }
+{ $description "Outputs the string currently displayed by the label." } ;
+
+HELP: set-label-string
+{ $values { "label" label } { "string" string } }
+{ $description "Sets the string currently displayed by the label. The string is permitted to contain line breaks. After calling this word, you must also call " { $link relayout } " on the label." } ;
+
+HELP: <label-control>
+{ $values { "model" model } { "gadget" "a new " { $link gadget } } }
+{ $description "Creates a control which displays the value of " { $snippet "model" } ", which is required to be a string. The label control is automatically updated when the model value changes." } ;
+
+{ label-string set-label-string } related-words
+{ <label> <label-control> } related-words
+
+ARTICLE: "ui.gadgets.labels" "Label gadgets"
+"A label displays a piece of text, either a single line string or an array of line strings."
+{ $subsection label }
+{ $subsection <label> }
+{ $subsection <label-control> }
+{ $subsection label-string }
+{ $subsection set-label-string }
+"Label specifiers are used by buttons, checkboxes and radio buttons:"
+{ $subsection >label } ;
+
+ABOUT: "ui.gadgets.labels"
+
+HELP: >label
+{ $values { "obj" "a label specifier" } { "gadget" "a new " { $link gadget } } }
+{ $description "Convert the object into a gadget suitable for use as the label of a button. If " { $snippet "obj" } " is already a gadget, does nothing. Otherwise creates a " { $link label } " gadget if it is a string and an empty gadget if " { $snippet "obj" } " is " { $link f } "." } ;
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays hashtables io kernel math namespaces
+opengl sequences strings splitting
+ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors
+models ;
+IN: ui.gadgets.labels
+
+! A label gadget draws a string.
+TUPLE: label < gadget text font color ;
+
+: label-string ( label -- string )
+ text>> dup string? [ "\n" join ] unless ; inline
+
+: set-label-string ( string label -- )
+ CHAR: \n pick memq? [
+ >r string-lines r> set-label-text
+ ] [
+ set-label-text
+ ] if ; inline
+
+: label-theme ( gadget -- gadget )
+ sans-serif-font >>font
+ black >>color ; inline
+
+: new-label ( string class -- label )
+ new-gadget
+ [ set-label-string ] keep
+ label-theme ; inline
+
+: <label> ( string -- label )
+ label new-label ;
+
+M: label pref-dim*
+ [ font>> open-font ] [ text>> ] bi text-dim ;
+
+M: label draw-gadget*
+ [ color>> set-color ]
+ [ [ font>> ] [ text>> ] bi origin get draw-text ] bi ;
+
+M: label gadget-text* label-string % ;
+
+TUPLE: label-control < label ;
+
+M: label-control model-changed
+ swap model-value over set-label-string relayout ;
+
+: <label-control> ( model -- gadget )
+ "" label-control new-label
+ swap >>model ;
+
+: text-theme ( gadget -- gadget )
+ black >>color
+ monospace-font >>font ;
+
+: reverse-video-theme ( label -- label )
+ white >>color
+ black solid-interior ;
+
+GENERIC: >label ( obj -- gadget )
+M: string >label <label> ;
+M: array >label <label> ;
+M: object >label ;
+M: f >label drop <gadget> ;
+
+: label-on-left ( gadget label -- button )
+ { 1 0 } <track>
+ swap >label f track-add
+ swap 1 track-add ;
+
+: label-on-right ( label gadget -- button )
+ { 1 0 } <track>
+ swap f track-add
+ swap >label 1 track-add ;
--- /dev/null
+Label gadgets display one or more lines of text with a single font and color
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: ui.backend ui.gadgets.worlds ;
+
+IN: ui.gadgets.lib
+
+: find-gl-context ( gadget -- ) find-world world-handle select-gl-context ;
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.commands help.markup help.syntax ui.gadgets
+ui.gadgets.presentations ui.operations kernel models classes ;
+IN: ui.gadgets.lists
+
+HELP: +secondary+
+{ $description "A key which may be set in the hashtable passed to " { $link define-operation } ". If set to a true value, this operation becomes the default operation performed when " { $snippet "RET" } " is pressed in a " { $link list } " gadget where the current selection is a presentation matching the operation's predicate." } ;
+
+HELP: list
+{ $class-description
+ "A list control is backed by a " { $link model } " holding a sequence of objects, and displays as a list of " { $link presentation } " instances of these objects."
+ $nl
+ "Lists are created by calling " { $link <list> } "."
+ { $command-map list "keyboard-navigation" }
+} ;
+
+HELP: <list>
+{ $values { "hook" "a quotation with stack effect " { $snippet "( list -- )" } } { "presenter" "a quotation with stack effect " { $snippet "( object -- label )" } } { "model" model } { "gadget" list } }
+{ $description "Creates a new " { $link list } "."
+$nl
+"The model value must be a sequence. The list displays presentations of elements with labels obtained by applying the " { $snippet "presenter" } " quotation to each object. The " { $snippet "hook" } " quotation is called when a presentation is selected." } ;
+
+HELP: list-value
+{ $values { "list" list } { "object" object } }
+{ $description "Outputs the currently selected list value." } ;
+
+ARTICLE: "ui.gadgets.lists" "List gadgets"
+"A list displays a list of presentations."
+{ $subsection list }
+{ $subsection <list> }
+{ $subsection list-value } ;
+
+ABOUT: "ui.gadgets.lists"
--- /dev/null
+IN: ui.gadgets.lists.tests
+USING: ui.gadgets.lists models prettyprint math tools.test
+kernel ;
+
+[ ] [ [ drop ] [ 3 + . ] f <model> <list> invoke-value-action ] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors ui.commands ui.gestures ui.render ui.gadgets
+ui.gadgets.labels ui.gadgets.scrollers
+kernel sequences models opengl math math.order namespaces
+ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
+math.vectors classes.tuple math.geometry.rect colors ;
+
+IN: ui.gadgets.lists
+
+TUPLE: list < pack index presenter color hook ;
+
+: list-theme ( list -- list )
+ T{ rgba f 0.8 0.8 1.0 1.0 } >>color ; inline
+
+: <list> ( hook presenter model -- gadget )
+ list new-gadget
+ { 0 1 } >>orientation
+ 1 >>fill
+ 0 >>index
+ swap >>model
+ swap >>presenter
+ swap >>hook
+ list-theme ;
+
+: calc-bounded-index ( n list -- m )
+ control-value length 1- min 0 max ;
+
+: bound-index ( list -- )
+ dup list-index over calc-bounded-index
+ swap set-list-index ;
+
+: list-presentation-hook ( list -- quot )
+ hook>> [ [ [ list? ] is? ] find-parent ] prepend ;
+
+: <list-presentation> ( hook elt presenter -- gadget )
+ keep >r >label text-theme r>
+ <presentation>
+ swap >>hook ; inline
+
+: <list-items> ( list -- seq )
+ [ list-presentation-hook ]
+ [ presenter>> ]
+ [ control-value ]
+ tri [
+ >r 2dup r> swap <list-presentation>
+ ] map 2nip ;
+
+M: list model-changed
+ nip
+ dup clear-gadget
+ dup <list-items> over swap add-gadgets drop
+ bound-index ;
+
+: selected-rect ( list -- rect )
+ dup list-index swap gadget-children ?nth ;
+
+M: list draw-gadget*
+ origin get [
+ dup list-color set-color
+ selected-rect [ rect-extent gl-fill-rect ] when*
+ ] with-translation ;
+
+M: list focusable-child* drop t ;
+
+: list-value ( list -- object )
+ dup list-index swap control-value ?nth ;
+
+: scroll>selected ( list -- )
+ #! We change the rectangle's width to zero to avoid
+ #! scrolling right.
+ [ selected-rect rect-bounds { 0 1 } v* <rect> ] keep
+ scroll>rect ;
+
+: list-empty? ( list -- ? ) control-value empty? ;
+
+: select-index ( n list -- )
+ dup list-empty? [
+ 2drop
+ ] [
+ [ control-value length rem ] keep
+ [ set-list-index ] keep
+ [ relayout-1 ] keep
+ scroll>selected
+ ] if ;
+
+: select-previous ( list -- )
+ dup list-index 1- swap select-index ;
+
+: select-next ( list -- )
+ dup list-index 1+ swap select-index ;
+
+: invoke-value-action ( list -- )
+ dup list-empty? [
+ dup list-hook call
+ ] [
+ dup list-index swap nth-gadget invoke-secondary
+ ] if ;
+
+: select-gadget ( gadget list -- )
+ swap over gadget-children index
+ [ swap select-index ] [ drop ] if* ;
+
+: clamp-loc ( point max -- point )
+ vmin { 0 0 } vmax ;
+
+: select-at ( point list -- )
+ [ rect-dim clamp-loc ] keep
+ [ pick-up ] keep
+ select-gadget ;
+
+: list-page ( list vec -- )
+ >r dup selected-rect rect-bounds 2 v/n v+
+ over visible-dim r> v* v+ swap select-at ;
+
+: list-page-up ( list -- ) { 0 -1 } list-page ;
+
+: list-page-down ( list -- ) { 0 1 } list-page ;
+
+list "keyboard-navigation" "Lists can be navigated from the keyboard." {
+ { T{ button-down } request-focus }
+ { T{ key-down f f "UP" } select-previous }
+ { T{ key-down f f "DOWN" } select-next }
+ { T{ key-down f f "PAGE_UP" } list-page-up }
+ { T{ key-down f f "PAGE_DOWN" } list-page-down }
+ { T{ key-down f f "RET" } invoke-value-action }
+} define-command-map
--- /dev/null
+List gadgets display a keyboard-navigatable list of presentations
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets help.markup help.syntax ui.gadgets.worlds
+kernel ;
+IN: ui.gadgets.menus
+
+HELP: <commands-menu>
+{ $values { "hook" "a quotation with stack effect " { $snippet "( button -- )" } } { "target" object } { "commands" "a sequence of commands" } { "gadget" "a new " { $link gadget } } }
+{ $description "Creates a popup menu of commands which are to be invoked on " { $snippet "target" } ". The " { $snippet "hook" } " quotation is run before a command is invoked." } ;
+
+HELP: show-menu
+{ $values { "gadget" gadget } { "owner" gadget } }
+{ $description "Displays a popup menu in the " { $link world } " containing " { $snippet "owner" } " at the current mouse location." } ;
--- /dev/null
+! Copyright (C) 2005, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays ui.commands ui.gadgets ui.gadgets.buttons
+ui.gadgets.worlds ui.gestures generic hashtables kernel math
+models namespaces opengl sequences math.vectors
+ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors
+math.geometry.rect ;
+IN: ui.gadgets.menus
+
+: menu-loc ( world menu -- loc )
+ >r rect-dim r> pref-dim [v-] hand-loc get-global vmin ;
+
+TUPLE: menu-glass < gadget ;
+
+: <menu-glass> ( menu world -- glass )
+ menu-glass new-gadget
+ >r over menu-loc over set-rect-loc r>
+ [ swap add-gadget drop ] keep ;
+
+M: menu-glass layout* gadget-child prefer ;
+
+: hide-glass ( world -- )
+ dup world-glass [ unparent ] when*
+ f swap set-world-glass ;
+
+: show-glass ( gadget world -- )
+ over hand-clicked set-global
+ [ hide-glass ] keep
+ [ swap add-gadget drop ] 2keep
+ set-world-glass ;
+
+: show-menu ( gadget owner -- )
+ find-world [ <menu-glass> ] keep show-glass ;
+
+\ menu-glass H{
+ { T{ button-down } [ find-world [ hide-glass ] when* ] }
+ { T{ drag } [ update-clicked drop ] }
+} set-gestures
+
+: <menu-item> ( hook target command -- button )
+ dup command-name -rot command-button-quot
+ swapd
+ [ hand-clicked get find-world hide-glass ]
+ 3append <roll-button> ;
+
+: menu-theme ( gadget -- gadget )
+ light-gray solid-interior
+ faint-boundary ;
+
+: <commands-menu> ( hook target commands -- gadget )
+ <filled-pile>
+ -roll
+ [ <menu-item> add-gadget ] with with each
+ 5 <border> menu-theme ;
--- /dev/null
+Menu gadgets pop up as a list of commands at the mouse location
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets help.markup help.syntax generic kernel
+classes.tuple quotations ;
+IN: ui.gadgets.packs
+
+ARTICLE: "ui-pack-layout" "Pack layouts"
+"Pack gadgets layout their children along a single axis."
+{ $subsection pack }
+"Creating empty packs:"
+{ $subsection <pack> }
+{ $subsection <pile> }
+{ $subsection <shelf> }
+
+"For more control, custom layouts can reuse portions of pack layout logic:"
+{ $subsection pack-pref-dim }
+{ $subsection pack-layout } ;
+
+HELP: pack
+{ $class-description "A gadget which lays out its children along a single axis stored in the " { $link gadget-orientation } " slot. Can be constructed with one of the following words:"
+{ $list
+ { $link <pack> }
+ { $link <pile> }
+ { $link <shelf> }
+}
+"Packs have the following slots:"
+{ $list
+ { { $link pack-align } " a rational number between 0 and 1, the alignment of gadgets along the axis perpendicular to the pack's orientation" }
+ { { $link pack-fill } " a rational number between 0 and 1, where 0 gives each gadget its preferred size and 1 fills the dimension perpendicular to the pack's orientation" }
+ { { $link pack-gap } " a pair of integers, the horizontal and vertical gap between children" }
+}
+"Custom gadgets can inherit from the " { $link pack } " class and implement their own " { $link pref-dim* } " and " { $link layout* } " methods, reusing pack layout logic by calling " { $link pack-pref-dim } " and " { $link pack-layout } "." } ;
+
+HELP: pack-layout
+{ $values { "pack" "a new " { $link pack } } { "sizes" "a sequence of pairs of integers" } }
+{ $description "Lays out the pack's children along the " { $link gadget-orientation } " of the pack, with each gadget receiving its size from the corresponding index of the " { $snippet "sizes" } " sequence." }
+{ $notes
+ "This word is useful if you are writing your own layout gadget which inherits from " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
+} ;
+
+HELP: <pack>
+{ $values { "orientation" "an orientation specifier" } { "pack" "a new " { $link pack } } }
+{ $description "Creates a new pack which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
+
+{ <pack> <pile> <shelf> } related-words
+
+HELP: <pile>
+{ $values { "pack" "a new " { $link pack } } }
+{ $description "Creates a new " { $link pack } " which lays out its children vertically." } ;
+
+HELP: <shelf>
+{ $values { "pack" "a new " { $link pack } } }
+{ $description "Creates a new " { $link pack } " which lays out its children horizontally." } ;
+
+HELP: pack-pref-dim
+{ $values { "gadget" gadget } { "sizes" "a sequence of pairs of integers" } { "dim" "a pair of integers" } }
+{ $description "Computes the preferred size of a pack, with each gadget receiving its size from the corresponding index of the " { $snippet "sizes" } " sequence." }
+{ $notes
+ "This word is useful if you are writing your own layout gadget which inherits from " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
+} ;
+
+ABOUT: "ui-pack-layout"
--- /dev/null
+IN: ui.gadgets.packs.tests
+USING: ui.gadgets.packs ui.gadgets.labels ui.gadgets ui.render
+kernel namespaces tools.test math.parser sequences math.geometry.rect ;
+
+[ t ] [
+ { 0 0 } { 100 100 } <rect> clip set
+
+ <pile>
+ 100 [ number>string <label> add-gadget ] each
+ dup layout
+
+ visible-children [ label? ] all?
+] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences ui.gadgets kernel math math.functions
+math.vectors namespaces math.order accessors math.geometry.rect ;
+IN: ui.gadgets.packs
+
+TUPLE: pack < gadget
+{ align initial: 0 }
+{ fill initial: 0 }
+{ gap initial: { 0 0 } } ;
+
+: packed-dim-2 ( gadget sizes -- list )
+ [ over rect-dim over v- rot pack-fill v*n v+ ] with map ;
+
+: packed-dims ( gadget sizes -- seq )
+ 2dup packed-dim-2 swap orient ;
+
+: gap-locs ( gap sizes -- seq )
+ { 0 0 } [ v+ over v+ ] accumulate 2nip ;
+
+: aligned-locs ( gadget sizes -- seq )
+ [ >r dup pack-align swap rect-dim r> v- n*v ] with map ;
+
+: packed-locs ( gadget sizes -- seq )
+ over pack-gap over gap-locs >r dupd aligned-locs r> orient ;
+
+: round-dims ( seq -- newseq )
+ { 0 0 } swap
+ [ swap v- dup [ ceiling >fixnum ] map [ swap v- ] keep ] map
+ nip ;
+
+: pack-layout ( pack sizes -- )
+ round-dims over gadget-children
+ >r dupd packed-dims r> 2dup [ (>>dim) ] 2each
+ >r packed-locs r> [ set-rect-loc ] 2each ;
+
+: <pack> ( orientation -- pack )
+ pack new-gadget
+ swap >>orientation ;
+
+: <pile> ( -- pack ) { 0 1 } <pack> ;
+
+: <filled-pile> ( -- pack ) <pile> 1 over set-pack-fill ;
+
+: <shelf> ( -- pack ) { 1 0 } <pack> ;
+
+: gap-dims ( gap sizes -- seeq )
+ [ dim-sum ] keep length 1 [-] rot n*v v+ ;
+
+: pack-pref-dim ( gadget sizes -- dim )
+ over pack-gap over gap-dims >r max-dim r>
+ rot gadget-orientation set-axis ;
+
+M: pack pref-dim*
+ dup gadget-children pref-dims pack-pref-dim ;
+
+M: pack layout*
+ dup gadget-children pref-dims pack-layout ;
+
+M: pack children-on ( rect gadget -- seq )
+ dup gadget-orientation swap gadget-children
+ [ fast-children-on ] keep <slice> ;
--- /dev/null
+Pack gadgets arrange children horizontally or vertically
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets models help.markup help.syntax io kernel
+quotations ;
+IN: ui.gadgets.panes
+
+HELP: pane
+{ $class-description "A pane " { $link gadget } " displays formatted text which is written to a " { $link pane-stream } " targetting the pane. Panes are created by calling " { $link <pane> } ", " { $link <scrolling-pane> } " or " { $link <pane-control> } "." } ;
+
+HELP: <pane>
+{ $values { "pane" "a new " { $link pane } } }
+{ $description "Creates a new " { $link pane } " gadget." } ;
+
+HELP: write-gadget
+{ $values { "gadget" gadget } { "stream" "an output stream" } }
+{ $contract "Writes a gadget to the stream." }
+{ $notes "Not all streams support this operation." } ;
+
+{ write-gadget print-gadget gadget. } related-words
+
+HELP: print-gadget
+{ $values { "gadget" gadget } { "stream" "an output stream" } }
+{ $description "Writes a gadget to the stream, followed by a newline." }
+{ $notes "Not all streams support this operation." } ;
+
+HELP: gadget.
+{ $values { "gadget" gadget } }
+{ $description "Writes a gadget followed by a newline to " { $link output-stream } "." }
+{ $notes "Not all streams support this operation." } ;
+
+HELP: ?nl
+{ $values { "stream" pane-stream } }
+{ $description "Inserts a line break in the pane unless the current line is empty." } ;
+
+HELP: with-pane
+{ $values { "pane" pane } { "quot" quotation } }
+{ $description "Clears the pane and calls the quotation in a new scope where " { $link output-stream } " is rebound to a " { $link pane-stream } " writing to the pane." } ;
+
+HELP: make-pane
+{ $values { "quot" quotation } { "gadget" "a new " { $link gadget } } }
+{ $description "Calls the quotation in a new scope where " { $link output-stream } " is rebound to a " { $link pane-stream } " writing to a new pane. The output area of the new pane is output on the stack after the quotation returns. The pane itself is not output." } ;
+
+HELP: <scrolling-pane>
+{ $values { "pane" "a new " { $link pane } } }
+{ $description "Creates a new " { $link pane } " gadget which scrolls any scroll pane containing it to the bottom on output. behaving much like a terminal or logger." } ;
+
+HELP: <pane-control>
+{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "pane" "a new " { $link pane } } }
+{ $description "Creates a new control delegating to a " { $link pane } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
+
+HELP: pane-stream
+{ $class-description "Pane streams implement the portion of the " { $link "stream-protocol" } " responsible for output of text, including full support for " { $link "styles" } ". Pane streams also support direct output of gadgets via " { $link write-gadget } " and " { $link print-gadget } ". Pane streams are created by calling " { $link <pane-stream> } "." } ;
+
+HELP: <pane-stream> ( pane -- stream )
+{ $values { "pane" pane } { "stream" "a new " { $link pane-stream } } }
+{ $description "Creates a new " { $link pane-stream } " for writing to " { $snippet "pane" } "." } ;
+
+{ with-pane make-pane } related-words
+
+ARTICLE: "ui.gadgets.panes" "Pane gadgets"
+"A pane displays formatted text."
+{ $subsection pane }
+{ $subsection <pane> }
+{ $subsection <scrolling-pane> }
+{ $subsection <pane-control> }
+"Panes are written to by creating a special output stream:"
+{ $subsection pane-stream }
+{ $subsection <pane-stream> }
+"In addition to the stream output words (" { $link "stream-protocol" } ", pane streams can have gadgets written to them:"
+{ $subsection write-gadget }
+{ $subsection print-gadget }
+{ $subsection gadget. }
+"The " { $link gadget. } " word is useful for interactive debugging of gadgets in the listener."
+$nl
+"There are a few combinators for working with panes:"
+{ $subsection with-pane }
+{ $subsection make-pane } ;
+
+ABOUT: "ui.gadgets.panes"
--- /dev/null
+IN: ui.gadgets.panes.tests
+USING: alien ui.gadgets.panes ui.gadgets namespaces
+kernel sequences io io.styles io.streams.string tools.test
+prettyprint definitions help help.syntax help.markup
+help.stylesheet splitting tools.test.ui models math summary
+inspector ;
+
+: #children "pane" get gadget-children length ;
+
+[ ] [ <pane> "pane" set ] unit-test
+
+[ ] [ #children "num-children" set ] unit-test
+
+[ ] [
+ "pane" get <pane-stream> [ 10000 [ . ] each ] with-output-stream*
+] unit-test
+
+[ t ] [ #children "num-children" get = ] unit-test
+
+: test-gadget-text
+ dup make-pane gadget-text dup print "======" print
+ swap with-string-writer dup print "\n" ?tail drop "\n" ?tail drop = ;
+
+[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
+[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
+[ t ] [
+ [
+ H{ { wrap-margin 100 } } [ "hello" pprint ] with-nesting
+ ] test-gadget-text
+] unit-test
+[ t ] [
+ [
+ H{ { wrap-margin 100 } } [
+ H{ } [
+ "hello" pprint
+ ] with-style
+ ] with-nesting
+ ] test-gadget-text
+] unit-test
+[ t ] [ [ [ 1 2 3 ] pprint ] test-gadget-text ] unit-test
+[ t ] [ [ \ + describe ] test-gadget-text ] unit-test
+[ t ] [ [ \ = see ] test-gadget-text ] unit-test
+[ t ] [ [ \ = help ] test-gadget-text ] unit-test
+
+[ t ] [
+ [
+ title-style get [
+ "Hello world" write
+ ] with-style
+ ] test-gadget-text
+] unit-test
+
+
+[ t ] [
+ [
+ title-style get [
+ "Hello world" write
+ ] with-nesting
+ ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [
+ title-style get [
+ title-style get [
+ "Hello world" write
+ ] with-nesting
+ ] with-style
+ ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [
+ title-style get [
+ title-style get [
+ [ "Hello world" write ] ($block)
+ ] with-nesting
+ ] with-style
+ ] test-gadget-text
+] unit-test
+
+ARTICLE: "test-article-1" "This is a test article"
+"Hello world, how are you today." ;
+
+[ t ] [ [ "test-article-1" $title ] test-gadget-text ] unit-test
+
+[ t ] [ [ "test-article-1" help ] test-gadget-text ] unit-test
+
+ARTICLE: "test-article-2" "This is a test article"
+"Hello world, how are you today."
+{ $table { "a" "b" } { "c" "d" } } ;
+
+[ t ] [ [ "test-article-2" help ] test-gadget-text ] unit-test
+
+<pane> [ \ = see ] with-pane
+<pane> [ \ = help ] with-pane
+
+[ ] [
+ \ = <model> [ see ] <pane-control> [ ] with-grafted-gadget
+] unit-test
--- /dev/null
+! 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 ;
+
+IN: ui.gadgets.panes
+
+TUPLE: pane < pack
+ output current prototype scrolls?
+ selection-color caret mark selecting? ;
+
+: clear-selection ( pane -- pane ) f >>caret f >>mark ;
+
+: add-output ( pane current -- pane ) [ >>output ] [ add-gadget ] bi ;
+: add-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ;
+
+: prepare-line ( pane -- pane )
+ clear-selection
+ dup prototype>> clone add-current ;
+
+: 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 ( pane -- string/f ) selected-children gadget-text ;
+
+: pane-clear ( pane -- )
+ clear-selection
+ [ pane-output clear-incremental ]
+ [ pane-current clear-gadget ]
+ bi ;
+
+: new-pane ( class -- pane )
+ new-gadget
+ { 0 1 } >>orientation
+ <shelf> >>prototype
+ <incremental> add-output
+ prepare-line
+ selection-color >>selection-color ;
+
+: <pane> ( -- pane ) pane new-pane ;
+
+GENERIC: draw-selection ( loc obj -- )
+
+: if-fits ( rect quot -- )
+ >r clip get over intersects? r> [ drop ] if ; inline
+
+M: gadget draw-selection ( loc gadget -- )
+ swap offset-rect [ rect-extent gl-fill-rect ] if-fits ;
+
+M: node draw-selection ( loc node -- )
+ 2dup node-value swap offset-rect [
+ drop 2dup
+ [ node-value rect-loc v+ ] keep
+ node-children [ draw-selection ] with each
+ ] if-fits 2drop ;
+
+M: pane draw-gadget*
+ dup gadget-selection? [
+ dup pane-selection-color set-color
+ origin get over rect-loc v- swap selected-children
+ [ draw-selection ] with each
+ ] [
+ drop
+ ] if ;
+
+: scroll-pane ( pane -- )
+ dup pane-scrolls? [ scroll>bottom ] [ drop ] if ;
+
+TUPLE: pane-stream pane ;
+
+C: <pane-stream> pane-stream
+
+: smash-line ( current -- gadget )
+ dup gadget-children {
+ { [ dup empty? ] [ 2drop "" <label> ] }
+ { [ dup length 1 = ] [ nip first ] }
+ [ drop ]
+ } cond ;
+
+: smash-pane ( pane -- gadget ) pane-output smash-line ;
+
+: pane-nl ( pane -- pane )
+ dup pane-current dup unparent smash-line
+ over pane-output add-incremental
+ prepare-line ;
+
+: pane-write ( pane seq -- )
+ [ pane-nl ]
+ [ over pane-current stream-write ]
+ interleave drop ;
+
+: pane-format ( style pane seq -- )
+ [ pane-nl ]
+ [ 2over pane-current stream-format ]
+ interleave 2drop ;
+
+GENERIC: write-gadget ( gadget stream -- )
+
+M: pane-stream write-gadget ( gadget pane-stream -- )
+ pane>> current>> swap add-gadget drop ;
+
+M: style-stream write-gadget
+ stream>> write-gadget ;
+
+: print-gadget ( gadget stream -- )
+ tuck write-gadget stream-nl ;
+
+: gadget. ( gadget -- )
+ output-stream get print-gadget ;
+
+: ?nl ( stream -- )
+ dup pane-stream-pane pane-current gadget-children empty?
+ [ dup stream-nl ] unless drop ;
+
+: with-pane ( pane quot -- )
+ over scroll>top
+ over pane-clear >r <pane-stream> r>
+ over >r with-output-stream* r> ?nl ; inline
+
+: make-pane ( quot -- gadget )
+ <pane> [ swap with-pane ] keep smash-pane ; inline
+
+: <scrolling-pane> ( -- pane )
+ <pane> t over set-pane-scrolls? ;
+
+TUPLE: pane-control < pane quot ;
+
+M: pane-control model-changed ( model pane-control -- )
+ [ value>> ] [ dup quot>> ] bi* with-pane ;
+
+: <pane-control> ( model quot -- pane )
+ pane-control new-pane
+ swap >>quot
+ swap >>model ;
+
+: do-pane-stream ( pane-stream quot -- )
+ >r pane-stream-pane r> keep scroll-pane ; inline
+
+M: pane-stream stream-nl
+ [ pane-nl drop ] do-pane-stream ;
+
+M: pane-stream stream-write1
+ [ pane-current stream-write1 ] do-pane-stream ;
+
+M: pane-stream stream-write
+ [ swap string-lines pane-write ] do-pane-stream ;
+
+M: pane-stream stream-format
+ [ rot string-lines pane-format ] do-pane-stream ;
+
+M: pane-stream dispose drop ;
+
+M: pane-stream stream-flush drop ;
+
+M: pane-stream make-span-stream
+ swap <style-stream> <ignore-close-stream> ;
+
+! Character styles
+
+: apply-style ( style gadget key quot -- style gadget )
+ >r pick at r> when* ; inline
+
+: apply-foreground-style ( style gadget -- style gadget )
+ foreground [ over set-label-color ] apply-style ;
+
+: apply-background-style ( style gadget -- style gadget )
+ background [ solid-interior ] apply-style ;
+
+: specified-font ( style -- font )
+ [ font swap at "monospace" or ] keep
+ [ font-style swap at plain or ] keep
+ font-size swap at 12 or 3array ;
+
+: apply-font-style ( style gadget -- style gadget )
+ over specified-font over set-label-font ;
+
+: apply-presentation-style ( style gadget -- style gadget )
+ presented [ <presentation> ] apply-style ;
+
+: style-label ( style gadget -- gadget )
+ apply-foreground-style
+ apply-background-style
+ apply-font-style
+ apply-presentation-style
+ nip ; inline
+
+: <styled-label> ( style text -- gadget )
+ <label> style-label ;
+
+! Paragraph styles
+
+: apply-wrap-style ( style pane -- style pane )
+ wrap-margin [
+ 2dup <paragraph> >>prototype drop
+ <paragraph> >>current
+ ] apply-style ;
+
+: apply-border-color-style ( style gadget -- style gadget )
+ border-color [ solid-boundary ] apply-style ;
+
+: apply-page-color-style ( style gadget -- style gadget )
+ page-color [ solid-interior ] apply-style ;
+
+: apply-path-style ( style gadget -- style gadget )
+ presented-path [ <editable-slot> ] apply-style ;
+
+: apply-border-width-style ( style gadget -- style gadget )
+ border-width [ <border> ] apply-style ;
+
+: apply-printer-style ( style gadget -- style gadget )
+ presented-printer [ [ make-pane ] curry >>printer ] apply-style ;
+
+: style-pane ( style pane -- pane )
+ apply-border-width-style
+ apply-border-color-style
+ apply-page-color-style
+ apply-presentation-style
+ apply-path-style
+ apply-printer-style
+ nip ;
+
+TUPLE: nested-pane-stream < pane-stream style parent ;
+
+: new-nested-pane-stream ( style parent class -- stream )
+ new
+ swap >>parent
+ swap <pane> apply-wrap-style [ >>style ] [ >>pane ] bi* ;
+ inline
+
+: unnest-pane-stream ( stream -- child parent )
+ dup ?nl
+ dup style>>
+ over pane>> smash-pane style-pane
+ swap parent>> ;
+
+TUPLE: pane-block-stream < nested-pane-stream ;
+
+M: pane-block-stream dispose
+ unnest-pane-stream write-gadget ;
+
+M: pane-stream make-block-stream
+ pane-block-stream new-nested-pane-stream ;
+
+! Tables
+: apply-table-gap-style ( style grid -- style grid )
+ table-gap [ over set-grid-gap ] apply-style ;
+
+: apply-table-border-style ( style grid -- style grid )
+ table-border [ <grid-lines> over set-gadget-boundary ]
+ apply-style ;
+
+: styled-grid ( style grid -- grid )
+ <grid>
+ f over set-grid-fill?
+ apply-table-gap-style
+ apply-table-border-style
+ nip ;
+
+TUPLE: pane-cell-stream < nested-pane-stream ;
+
+M: pane-cell-stream dispose ?nl ;
+
+M: pane-stream make-cell-stream
+ pane-cell-stream new-nested-pane-stream ;
+
+M: pane-stream stream-write-table
+ >r
+ swap [ [ pane-stream-pane smash-pane ] map ] map
+ styled-grid
+ r> print-gadget ;
+
+! Stream utilities
+M: pack dispose drop ;
+
+M: paragraph dispose drop ;
+
+: gadget-write ( string gadget -- )
+ over empty?
+ [ 2drop ] [ >r <label> text-theme r> swap add-gadget drop ] if ;
+
+M: pack stream-write gadget-write ;
+
+: gadget-bl ( style stream -- )
+ >r " " <word-break-gadget> style-label r> swap add-gadget drop ;
+
+M: paragraph stream-write
+ swap " " split
+ [ H{ } over gadget-bl ] [ over gadget-write ] interleave
+ drop ;
+
+: gadget-write1 ( char gadget -- )
+ >r 1string r> stream-write ;
+
+M: pack stream-write1 gadget-write1 ;
+
+M: paragraph stream-write1
+ over CHAR: \s =
+ [ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
+
+: gadget-format ( string style stream -- )
+ pick empty?
+ [ 3drop ] [ >r swap <styled-label> r> swap add-gadget drop ] if ;
+
+M: pack stream-format
+ gadget-format ;
+
+M: paragraph stream-format
+ presented pick at [
+ gadget-format
+ ] [
+ rot " " split
+ [ 2dup gadget-bl ]
+ [ 2over gadget-format ] interleave
+ 2drop
+ ] if ;
+
+: caret>mark ( pane -- pane )
+ dup caret>> >>mark
+ dup relayout-1 ;
+
+GENERIC: sloppy-pick-up* ( loc gadget -- n )
+
+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 ;
+
+M: f sloppy-pick-up*
+ 2drop f ;
+
+: wet-and-sloppy ( loc gadget n -- newloc newgadget )
+ swap nth-gadget [ rect-loc v- ] keep ;
+
+: sloppy-pick-up ( loc gadget -- path )
+ 2dup sloppy-pick-up* dup
+ [ [ wet-and-sloppy sloppy-pick-up ] keep prefix ]
+ [ 3drop { } ]
+ if ;
+
+: move-caret ( pane -- pane )
+ dup hand-rel
+ over sloppy-pick-up
+ over set-pane-caret
+ dup relayout-1 ;
+
+: begin-selection ( pane -- )
+ move-caret f swap set-pane-mark ;
+
+: extend-selection ( pane -- )
+ hand-moved? [
+ dup selecting?>> [
+ move-caret
+ ] [
+ dup hand-clicked get child? [
+ t >>selecting?
+ dup hand-clicked set-global
+ move-caret
+ caret>mark
+ ] when
+ ] if
+ dup dup pane-caret gadget-at-path scroll>gadget
+ ] when drop ;
+
+: end-selection ( pane -- )
+ f >>selecting?
+ hand-moved? [
+ [ com-copy-selection ] [ request-focus ] bi
+ ] [
+ relayout-1
+ ] if ;
+
+: select-to-caret ( pane -- )
+ dup pane-mark [ caret>mark ] unless
+ move-caret
+ dup request-focus
+ com-copy-selection ;
+
+pane H{
+ { T{ button-down } [ begin-selection ] }
+ { T{ button-down f { S+ } 1 } [ select-to-caret ] }
+ { T{ button-up f { S+ } 1 } [ drop ] }
+ { T{ button-up } [ end-selection ] }
+ { T{ drag } [ extend-selection ] }
+ { T{ copy-action } [ com-copy ] }
+} set-gestures
--- /dev/null
+Pane gadgets display formatted stream output
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2005, 2007 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays ui.gadgets ui.gadgets.labels ui.render kernel math
+namespaces sequences math.order math.geometry.rect ;
+IN: ui.gadgets.paragraphs
+
+! A word break gadget
+TUPLE: word-break-gadget < label ;
+
+: <word-break-gadget> ( text -- gadget )
+ word-break-gadget new-label ;
+
+M: word-break-gadget draw-gadget* drop ;
+
+! A gadget that arranges its children in a word-wrap style.
+TUPLE: paragraph < gadget margin ;
+
+: <paragraph> ( margin -- gadget )
+ paragraph new-gadget
+ { 1 0 } over set-gadget-orientation
+ [ set-paragraph-margin ] keep ;
+
+SYMBOL: x SYMBOL: max-x
+
+SYMBOL: y SYMBOL: max-y
+
+SYMBOL: line-height
+
+SYMBOL: margin
+
+: overrun? ( width -- ? ) x get + margin get > ;
+
+: zero-vars ( seq -- ) [ 0 swap set ] each ;
+
+: wrap-line ( -- )
+ line-height get y +@
+ { x line-height } zero-vars ;
+
+: wrap-pos ( -- pos ) x get y get 2array ; inline
+
+: advance-x ( x -- )
+ x +@
+ x get max-x [ max ] change ;
+
+: advance-y ( y -- )
+ dup line-height [ max ] change
+ y get + max-y [ max ] change ;
+
+: wrap-step ( quot child -- )
+ dup pref-dim [
+ over word-break-gadget? [
+ dup first overrun? [ wrap-line ] when
+ ] unless drop wrap-pos rot call
+ ] keep first2 advance-y advance-x ; inline
+
+: wrap-dim ( -- dim ) max-x get max-y get 2array ;
+
+: init-wrap ( paragraph -- )
+ paragraph-margin margin set
+ { x max-x y max-y line-height } zero-vars ;
+
+: do-wrap ( paragraph quot -- dim )
+ [
+ swap dup init-wrap
+ [ wrap-step ] with each-child wrap-dim
+ ] with-scope ; inline
+
+M: paragraph pref-dim*
+ [ 2drop ] do-wrap ;
+
+M: paragraph layout*
+ [ swap dup prefer set-rect-loc ] do-wrap drop ;
--- /dev/null
+Paragraph gadgets lay out their children from left to right, wrapping at a fixed margin
--- /dev/null
+
+USING: kernel quotations arrays sequences math math.ranges fry
+ opengl opengl.gl ui.render ui.gadgets.cartesian processing.shapes
+ accessors ;
+
+IN: ui.gadgets.plot
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: plot < cartesian functions points ;
+
+: init-plot ( plot -- plot )
+ init-cartesian
+ { } >>functions
+ 100 >>points ;
+
+: <plot> ( -- plot ) plot new init-plot ;
+
+: step-size ( plot -- step-size )
+ [ [ x-max>> ] [ x-min>> ] bi - ] [ points>> ] bi / ;
+
+: plot-range ( plot -- range )
+ [ x-min>> ] [ x-max>> ] [ step-size ] tri <range> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: function function color ;
+
+GENERIC: plot-function ( plot object -- plot )
+
+M: callable plot-function ( plot quotation -- plot )
+ >r dup plot-range r> '[ dup @ 2array ] map line-strip ;
+
+M: function plot-function ( plot function -- plot )
+ dup color>> dup [ >stroke-color ] [ drop ] if
+ >r dup plot-range r> function>> '[ dup @ 2array ] map line-strip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: plot-functions ( plot -- plot ) dup functions>> [ plot-function ] each ;
+
+: draw-axis ( plot -- plot )
+ dup
+ [ [ x-min>> ] [ drop 0 ] bi 2array ]
+ [ [ x-max>> ] [ drop 0 ] bi 2array ] bi line*
+ dup
+ [ [ drop 0 ] [ y-min>> ] bi 2array ]
+ [ [ drop 0 ] [ y-max>> ] bi 2array ] bi line* ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: ui.gadgets.slate ;
+
+M: plot draw-slate ( plot -- plot )
+ 2 glLineWidth
+ draw-axis
+ plot-functions
+ fill-mode
+ 1 glLineWidth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: add-function ( plot function -- plot )
+ over functions>> swap suffix >>functions ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: x-span ( plot -- span ) [ x-max>> ] [ x-min>> ] bi - ;
+: y-span ( plot -- span ) [ y-max>> ] [ y-min>> ] bi - ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: ui.gestures ui.gadgets ;
+
+: left ( plot -- plot )
+ dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min
+ dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max
+ dup relayout-1 ;
+
+: right ( plot -- plot )
+ dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min
+ dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max
+ dup relayout-1 ;
+
+: down ( plot -- plot )
+ dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min
+ dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max
+ dup relayout-1 ;
+
+: up ( plot -- plot )
+ dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min
+ dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max
+ dup relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: zoom-in-horizontal ( plot -- plot )
+ dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min
+ dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max ;
+
+: zoom-in-vertical ( plot -- plot )
+ dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min
+ dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max ;
+
+: zoom-in ( plot -- plot )
+ zoom-in-horizontal
+ zoom-in-vertical
+ dup relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: zoom-out-horizontal ( plot -- plot )
+ dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min
+ dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max ;
+
+: zoom-out-vertical ( plot -- plot )
+ dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min
+ dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max ;
+
+: zoom-out ( plot -- plot )
+ zoom-out-horizontal
+ zoom-out-vertical
+ dup relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+plot
+ H{
+ { T{ mouse-enter } [ request-focus ] }
+ { T{ key-down f f "LEFT" } [ left drop ] }
+ { T{ key-down f f "RIGHT" } [ right drop ] }
+ { T{ key-down f f "DOWN" } [ down drop ] }
+ { T{ key-down f f "UP" } [ up drop ] }
+ { T{ key-down f f "a" } [ zoom-in drop ] }
+ { T{ key-down f f "z" } [ zoom-out drop ] }
+ }
+set-gestures
\ No newline at end of file
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax ui.gadgets.buttons
+ui.gadgets.menus models ui.operations summary kernel
+ui.gadgets.worlds ui.gadgets ui.gadgets.status-bar ;
+IN: ui.gadgets.presentations
+
+HELP: presentation
+{ $class-description "A presentation is a " { $link button } " which represents an object. Left-clicking a presentation invokes the default " { $link operation } ", and right-clicking displays a menu of possible operations output by " { $link object-operations } "."
+$nl
+"Presentations are created by calling " { $link <presentation> } "."
+$nl
+"Presentations have two slots:"
+{ $list
+ { { $link presentation-object } " - the object being presented." }
+ { { $link presentation-hook } " - a quotation with stack effect " { $snippet "( presentation -- )" } ". The default value is " { $snippet "[ drop ]" } "." }
+} } ;
+
+HELP: invoke-presentation
+{ $values { "presentation" presentation } { "command" "a command" } }
+{ $description "Calls the " { $link presentation-hook } " and then invokes the command on the " { $link presentation-object } "." } ;
+
+{ invoke-presentation invoke-primary invoke-secondary } related-words
+
+HELP: invoke-primary
+{ $values { "presentation" presentation } }
+{ $description "Invokes the " { $link primary-operation } " associated to the " { $link presentation-object } ". This word is executed when the presentation is clicked with the left mouse button." } ;
+
+HELP: invoke-secondary
+{ $values { "presentation" presentation } }
+{ $description "Invokes the " { $link secondary-operation } " associated to the " { $link presentation-object } ". This word is executed when a list receives a " { $snippet "RET" } " key press." } ;
+
+HELP: <presentation>
+{ $values { "label" "a label" } { "object" object } { "button" "a new " { $link button } } }
+{ $description "Creates a new " { $link presentation } " derived from " { $link <roll-button> } "." }
+{ $see-also "presentations" } ;
+
+{ <button> <bevel-button> <command-button> <roll-button> <presentation> } related-words
+
+{ <commands-menu> <toolbar> operations-menu show-menu } related-words
+
+{ <status-bar> show-mouse-help show-status show-summary hide-status } related-words
+
+HELP: show-mouse-help
+{ $values { "presentation" presentation } }
+{ $description "Displays a " { $link summary } " of the " { $link presentation-object } "in the status bar of the " { $link world } " containing this presentation. This word is executed when the mouse enters the presentation." } ;
+
+ARTICLE: "ui.gadgets.presentations" "Presentation gadgets"
+"Outliner gadgets are usually not constructed directly, and instead are written to " { $link "ui.gadgets.panes" } " with formatted stream output words (" { $link "presentations" } ")."
+{ $subsection presentation }
+{ $subsection <presentation> }
+"Presentations remember the object they are presenting; operations can be performed on the presented object. See " { $link "ui-operations" } "." ;
+
+ABOUT: "ui.gadgets.presentations"
--- /dev/null
+IN: ui.gadgets.presentations.tests
+USING: math ui.gadgets.presentations ui.gadgets tools.test
+prettyprint ui.gadgets.buttons io io.streams.string kernel
+classes.tuple ;
+
+[ t ] [
+ "Hi" \ + <presentation> [ gadget? ] is?
+] unit-test
+
+[ "+" ] [
+ [
+ \ + f \ pprint <command-button> dup button-quot call
+ ] with-string-writer
+] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays accessors definitions hashtables io kernel
+prettyprint sequences strings io.styles words help math models
+namespaces quotations
+ui.gadgets ui.gadgets.borders ui.gadgets.buttons
+ui.gadgets.labels ui.gadgets.menus ui.gadgets.worlds
+ui.gadgets.status-bar ui.commands ui.operations ui.gestures ;
+IN: ui.gadgets.presentations
+
+TUPLE: presentation < button object hook ;
+
+: invoke-presentation ( presentation command -- )
+ over dup presentation-hook call
+ >r presentation-object r> invoke-command ;
+
+: invoke-primary ( presentation -- )
+ dup presentation-object primary-operation
+ invoke-presentation ;
+
+: invoke-secondary ( presentation -- )
+ dup presentation-object secondary-operation
+ invoke-presentation ;
+
+: show-mouse-help ( presentation -- )
+ dup presentation-object over show-summary button-update ;
+
+: <presentation> ( label object -- button )
+ swap [ invoke-primary ] presentation new-button
+ swap >>object
+ [ drop ] >>hook
+ roll-button-theme ;
+
+M: presentation ungraft*
+ dup hand-gadget get-global child? [ dup hide-status ] when
+ call-next-method ;
+
+: <operations-menu> ( presentation -- menu )
+ dup dup presentation-hook curry
+ swap presentation-object
+ dup object-operations <commands-menu> ;
+
+: operations-menu ( presentation -- )
+ dup <operations-menu> swap show-menu ;
+
+presentation H{
+ { T{ button-down f f 3 } [ operations-menu ] }
+ { T{ mouse-leave } [ dup hide-status button-update ] }
+ { T{ mouse-enter } [ show-mouse-help ] }
+ ! Responding to motion too allows nested presentations to
+ ! display status help properly, when the mouse leaves a
+ ! nested presentation and is still inside the parent, the
+ ! parent doesn't receive a mouse-enter
+ { T{ motion } [ show-mouse-help ] }
+} set-gestures
--- /dev/null
+Presentations display an interactive view of an object
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets help.markup help.syntax ui.gadgets.viewports
+ui.gadgets.sliders math.geometry.rect ;
+IN: ui.gadgets.scrollers
+
+HELP: scroller
+{ $class-description "A scroller consists of a " { $link viewport } " containing a child, together with horizontal and vertical " { $link slider } " gadgets which scroll the viewport's child. Scroller gadgets also support using a mouse scroll wheel."
+$nl
+"Scroller gadgets are created by calling " { $link <scroller> } "." } ;
+
+HELP: find-scroller
+{ $values { "gadget" gadget } { "scroller/f" "a " { $link scroller } " or " { $link f } } }
+{ $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link scroller } ". Outputs " { $link f } " if the gadget is not contained in a " { $link scroller } "." } ;
+
+HELP: scroller-value
+{ $values { "scroller" scroller } { "loc" "a pair of integers" } }
+{ $description "Outputs the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ;
+
+{ scroller-value scroll scroll>bottom scroll>top scroll>rect } related-words
+
+HELP: <scroller>
+{ $values { "gadget" gadget } { "scroller" "a new " { $link scroller } } }
+{ $description "Creates a new " { $link scroller } " for scrolling around " { $snippet "gadget" } "." } ;
+
+{ <viewport> <scroller> } related-words
+
+HELP: scroll
+{ $values { "scroller" scroller } { "value" "a pair of integers" } }
+{ $description "Sets the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ;
+
+HELP: relative-scroll-rect
+{ $values { "rect" rect } { "gadget" gadget } { "scroller" scroller } { "newrect" "a new " { $link rect } } }
+{ $description "Adjusts " { $snippet "rect" } " for the case where the gadget is not the immediate child of the scroller's viewport." } ;
+
+HELP: scroll>rect
+{ $values { "rect" rect } { "gadget" gadget } }
+{ $description "Ensures that a rectangular region relative to the top-left corner of " { $snippet "gadget" } " becomes visible in a " { $link scroller } " containing " { $snippet "gadget" } ". Does nothing if no parent of " { $snippet "gadget" } " is a " { $link scroller } "." } ;
+
+HELP: scroll>bottom
+{ $values { "gadget" gadget } }
+{ $description "Ensures that any " { $link scroller } " containing " { $snippet "gadget" } " is scrolled all the way down. Does nothing if no parent of " { $snippet "gadget" } " is a " { $link scroller } "." } ;
+
+HELP: scroll>top
+{ $values { "gadget" gadget } }
+{ $description "Ensures that any scroller containing " { $snippet "gadget" } " is scrolled all the way up. If no parent of " { $snippet "scroller" } " is a gadget, does nothing." } ;
+
+ARTICLE: "ui.gadgets.scrollers" "Scroller gadgets"
+"A scroller displays a gadget which is larger than the visible area."
+{ $subsection scroller }
+{ $subsection <scroller> }
+"Getting and setting the scroll position:"
+{ $subsection scroller-value }
+{ $subsection scroll }
+"Writing scrolling-aware gadgets:"
+{ $subsection scroll>bottom }
+{ $subsection scroll>top }
+{ $subsection scroll>rect }
+{ $subsection find-scroller } ;
+
+ABOUT: "ui.gadgets.scrollers"
--- /dev/null
+IN: ui.gadgets.scrollers.tests
+USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test
+kernel models models.compose models.range ui.gadgets.viewports
+ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
+ui.gadgets.sliders math math.vectors arrays sequences
+tools.test.ui math.geometry.rect ;
+
+[ ] [
+ <gadget> "g" set
+ "g" get <scroller> "s" set
+] unit-test
+
+[ { 100 200 } ] [
+ { 100 200 } "g" get scroll>rect
+ "s" get scroller-follows rect-loc
+] unit-test
+
+[ ] [ "s" get scroll>bottom ] unit-test
+[ t ] [ "s" get scroller-follows ] unit-test
+
+[ ] [
+ <gadget> dup "g" set
+ 10 1 0 100 <range> 20 1 0 100 <range> 2array <compose>
+ <viewport> "v" set
+] unit-test
+
+"v" get [
+ [ { 10 20 } ] [ "v" get gadget-model range-value ] unit-test
+
+ [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
+] with-grafted-gadget
+
+[ ] [
+ <gadget> { 100 100 } over set-rect-dim
+ dup "g" set <scroller> "s" set
+] unit-test
+
+[ ] [ { 50 50 } "s" get set-rect-dim ] unit-test
+
+[ ] [ "s" get layout ] unit-test
+
+"s" get [
+ [ { 34 34 } ] [ "s" get scroller-viewport rect-dim ] unit-test
+
+ [ { 106 106 } ] [ "s" get scroller-viewport viewport-dim ] unit-test
+
+ [ ] [ { 0 0 } "s" get scroll ] unit-test
+
+ [ { 0 0 } ] [ "s" get gadget-model range-min-value ] unit-test
+
+ [ { 106 106 } ] [ "s" get gadget-model range-max-value ] unit-test
+
+ [ ] [ { 10 20 } "s" get scroll ] unit-test
+
+ [ { 10 20 } ] [ "s" get gadget-model range-value ] unit-test
+
+ [ { 10 20 } ] [ "s" get scroller-viewport gadget-model range-value ] unit-test
+
+ [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
+] with-grafted-gadget
+
+<gadget> { 600 400 } over set-rect-dim "g1" set
+<gadget> { 600 10 } over set-rect-dim "g2" set
+"g2" get "g1" get swap add-gadget drop
+
+"g1" get <scroller>
+{ 300 300 } over set-rect-dim
+dup layout
+"s" set
+
+[ t ] [
+ 10 [
+ drop
+ "g2" get scroll>gadget
+ "s" get layout
+ "s" get scroller-value
+ ] map [ { 3 0 } = ] all?
+] unit-test
+
+[ ] [ "Hi" <label> dup "l" set <scroller> "s" set ] unit-test
+
+[ t ] [ "l" get find-scroller "s" get eq? ] unit-test
+[ t ] [ "l" get dup find-scroller scroller-viewport swap child? ] unit-test
+[ t ] [ "l" get find-scroller* "s" get eq? ] unit-test
+[ f ] [ "s" get scroller-viewport find-scroller* ] unit-test
+[ t ] [ "s" get @right grid-child slider? ] unit-test
+[ f ] [ "s" get @right grid-child find-scroller* ] unit-test
+
+\ <scroller> must-infer
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays ui.gadgets ui.gadgets.viewports
+ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
+ui.gadgets.sliders ui.gestures kernel math namespaces sequences
+models models.range models.compose
+combinators math.vectors classes.tuple math.geometry.rect ;
+IN: ui.gadgets.scrollers
+
+TUPLE: scroller < frame viewport x y follows ;
+
+: find-scroller ( gadget -- scroller/f )
+ [ [ scroller? ] is? ] find-parent ;
+
+: scroll-up-page ( scroller -- ) y>> -1 swap slide-by-page ;
+
+: scroll-down-page ( scroller -- ) y>> 1 swap slide-by-page ;
+
+: scroll-up-line ( scroller -- ) y>> -1 swap slide-by-line ;
+
+: scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
+
+: do-mouse-scroll ( scroller -- )
+ scroll-direction get-global first2
+ pick scroller-y slide-by-line
+ swap scroller-x slide-by-line ;
+
+scroller H{
+ { T{ mouse-scroll } [ do-mouse-scroll ] }
+} set-gestures
+
+: <scroller-model> ( -- model )
+ 0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
+
+: new-scroller ( gadget class -- scroller )
+ new-frame
+ t >>root?
+ <scroller-model> >>model
+ faint-boundary
+
+ dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add
+ dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
+
+ swap over model>> <viewport> >>viewport
+ dup viewport>> @center grid-add ;
+
+: <scroller> ( gadget -- scroller ) scroller new-scroller ;
+
+: scroll ( value scroller -- )
+ [
+ dup scroller-viewport rect-dim { 0 0 }
+ rot scroller-viewport viewport-dim 4array flip
+ ] keep
+ 2dup control-value = [ 2drop ] [ set-control-value ] if ;
+
+: rect-min ( rect1 rect2 -- rect )
+ >r [ rect-loc ] keep r> [ rect-dim ] bi@ vmin <rect> ;
+
+: (scroll>rect) ( rect scroller -- )
+ [
+ scroller-value vneg offset-rect
+ viewport-gap offset-rect
+ ] keep
+ [ scroller-viewport rect-min ] keep
+ [
+ scroller-viewport 2rect-extent
+ >r >r v- { 0 0 } vmin r> r> v- { 0 0 } vmax v+
+ ] keep dup scroller-value rot v+ swap scroll ;
+
+: relative-scroll-rect ( rect gadget scroller -- newrect )
+ viewport>> gadget-child relative-loc offset-rect ;
+
+: find-scroller* ( gadget -- scroller )
+ dup find-scroller dup [
+ 2dup scroller-viewport gadget-child
+ swap child? [ nip ] [ 2drop f ] if
+ ] [
+ 2drop f
+ ] if ;
+
+: scroll>rect ( rect gadget -- )
+ dup find-scroller* dup [
+ [ relative-scroll-rect ] keep
+ [ set-scroller-follows ] keep
+ relayout
+ ] [
+ 3drop
+ ] if ;
+
+: (scroll>gadget) ( gadget scroller -- )
+ >r { 0 0 } over pref-dim <rect> swap r>
+ [ relative-scroll-rect ] keep
+ (scroll>rect) ;
+
+: scroll>gadget ( gadget -- )
+ dup find-scroller* dup [
+ [ set-scroller-follows ] keep
+ relayout
+ ] [
+ 2drop
+ ] if ;
+
+: (scroll>bottom) ( scroller -- )
+ dup scroller-viewport viewport-dim { 0 1 } v* swap scroll ;
+
+: scroll>bottom ( gadget -- )
+ find-scroller [
+ t over set-scroller-follows relayout-1
+ ] when* ;
+
+: scroll>top ( gadget -- )
+ <zero-rect> swap scroll>rect ;
+
+GENERIC: update-scroller ( scroller follows -- )
+
+M: t update-scroller drop (scroll>bottom) ;
+
+M: gadget update-scroller swap (scroll>gadget) ;
+
+M: rect update-scroller swap (scroll>rect) ;
+
+M: f update-scroller drop dup scroller-value swap scroll ;
+
+M: scroller layout*
+ dup call-next-method
+ dup scroller-follows
+ [ update-scroller ] 2keep
+ swap set-scroller-follows ;
+
+M: scroller focusable-child*
+ scroller-viewport ;
+
+M: scroller model-changed
+ nip f swap set-scroller-follows ;
+
+TUPLE: limited-scroller < scroller fixed-dim ;
+
+: <limited-scroller> ( gadget dim -- scroller )
+ >r limited-scroller new-scroller r> >>fixed-dim ;
+
+M: limited-scroller pref-dim*
+ fixed-dim>> ;
--- /dev/null
+Scrollers display a user-chosen portion of a child which may have arbitrary dimensions
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces opengl ui.render ui.gadgets accessors ;
+
+IN: ui.gadgets.slate
+
+TUPLE: slate < gadget action pdim graft ungraft ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-slate ( slate -- slate )
+ init-gadget
+ [ ] >>action
+ { 200 200 } >>pdim
+ [ ] >>graft
+ [ ] >>ungraft ;
+
+: <slate> ( action -- slate )
+ slate new
+ init-slate
+ swap >>action ;
+
+M: slate pref-dim* ( slate -- dim ) pdim>> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: combinators arrays sequences math math.geometry
+ opengl.gl ui.gadgets.worlds ;
+
+: screen-y* ( gadget -- loc )
+ {
+ [ find-world height ]
+ [ screen-loc second ]
+ [ height ]
+ }
+ cleave
+ + - ;
+
+: screen-loc* ( gadget -- loc )
+ {
+ [ screen-loc first ]
+ [ screen-y* ]
+ }
+ cleave
+ 2array ;
+
+: setup-viewport ( gadget -- gadget )
+ dup
+ {
+ [ screen-loc* ]
+ [ dim>> ]
+ }
+ cleave
+ gl-viewport ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: default-coordinate-system ( gadget -- gadget )
+ dup
+ {
+ [ drop 0 ]
+ [ width 1 - ]
+ [ height 1 - ]
+ [ drop 0 ]
+ }
+ cleave
+ -1 1
+ glOrtho ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate graft* ( slate -- ) graft>> call ;
+M: slate ungraft* ( slate -- ) ungraft>> call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: establish-coordinate-system ( gadget -- gadget )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate establish-coordinate-system ( slate -- slate )
+ default-coordinate-system ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: draw-slate ( slate -- slate )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate draw-slate ( slate -- slate ) dup action>> call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate draw-gadget* ( slate -- )
+
+ GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity
+
+ establish-coordinate-system
+
+ GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity
+
+ setup-viewport
+
+ draw-slate
+
+ GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity
+ GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity
+
+ dup
+ find-world
+ ! The world coordinate system is a little wacky:
+ dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho
+ setup-viewport
+ drop
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax ui.gadgets models models.range ;
+IN: ui.gadgets.sliders
+
+HELP: elevator
+{ $class-description "An elevator is the part of a " { $link slider } " between the up/down arrow buttons, where a " { $link thumb } " may be moved up and down." } ;
+
+HELP: find-elevator
+{ $values { "gadget" gadget } { "elevator/f" "an " { $link elevator } " or " { $link f } } }
+{ $description "Finds the first parent of " { $snippet "gadget" } " which is an " { $link elevator } ". Outputs " { $link f } " if the gadget is not contained in an " { $link elevator } "." } ;
+
+HELP: slider
+{ $class-description "A slider is a control for graphically manipulating a " { $link "models-range" } "."
+$nl
+"Sliders are created by calling " { $link <x-slider> } " or " { $link <y-slider> } "." } ;
+
+HELP: find-slider
+{ $values { "gadget" gadget } { "slider/f" "a " { $link slider } " or " { $link f } } }
+{ $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link slider } ". Outputs " { $link f } " if the gadget is not contained in a " { $link slider } "." } ;
+
+HELP: thumb
+{ $class-description "A thumb is the gadget contained in a " { $link slider } "'s " { $link elevator } " which indicates the current scroll position and can be dragged up and down with the mouse." } ;
+
+HELP: slide-by
+{ $values { "amount" "an integer" } { "slider" slider } }
+{ $description "Adds the amount (which may be positive or negative) to the slider's current position." } ;
+
+HELP: slide-by-page
+{ $values { "amount" "an integer" } { "slider" slider } }
+{ $description "Adds the amount multiplied by " { $link slider-page } " to the slider's current position." } ;
+
+HELP: slide-by-line
+{ $values { "amount" "an integer" } { "slider" slider } }
+{ $description "Adds the amount multiplied by " { $link slider-line } " to the slider's current position." } ;
+
+HELP: <slider>
+{ $values { "range" range } { "orientation" "an orientation specifier" } { "slider" "a new " { $link slider } } }
+{ $description "Internal word for constructing sliders." }
+{ $notes "This does not build a complete slider, and user code should call " { $link <x-slider> } " or " { $link <y-slider> } " instead." } ;
+
+HELP: <x-slider>
+{ $values { "range" range } { "slider" slider } }
+{ $description "Creates a new horizontal " { $link slider } "." } ;
+
+HELP: <y-slider>
+{ $values { "range" range } { "slider" slider } }
+{ $description "Creates a new vertical " { $link slider } "." } ;
+
+{ <x-slider> <y-slider> } related-words
+
+ARTICLE: "ui.gadgets.sliders" "Slider gadgets"
+"A slider allows the user to graphically manipulate a value by moving a thumb back and forth."
+{ $subsection slider }
+{ $subsection <x-slider> }
+{ $subsection <y-slider> }
+"Changing slider values:"
+{ $subsection slide-by }
+{ $subsection slide-by-line }
+{ $subsection slide-by-page }
+"Since sliders are controls the value can be get and set by calling " { $link gadget-model } "." ;
+
+ABOUT: "ui.gadgets.sliders"
--- /dev/null
+! Copyright (C) 2005, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
+ui.gadgets.frames ui.gadgets.grids math.order
+ui.gadgets.theme ui.render kernel math namespaces sequences
+vectors models models.range math.vectors math.functions
+quotations colors math.geometry.rect ;
+IN: ui.gadgets.sliders
+
+TUPLE: elevator < gadget direction ;
+
+: find-elevator ( gadget -- elevator/f ) [ elevator? ] find-parent ;
+
+TUPLE: slider < frame elevator thumb saved line ;
+
+: find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
+
+: elevator-length ( slider -- n )
+ [ elevator>> dim>> ] [ orientation>> ] bi v. ;
+
+: min-thumb-dim 15 ;
+
+: slider-value ( gadget -- n ) gadget-model range-value >fixnum ;
+: slider-page ( gadget -- n ) gadget-model range-page-value ;
+: slider-max ( gadget -- n ) gadget-model range-max-value ;
+: slider-max* ( gadget -- n ) gadget-model range-max-value* ;
+
+: thumb-dim ( slider -- h )
+ dup slider-page over slider-max 1 max / 1 min
+ over elevator-length * min-thumb-dim max
+ over slider-elevator rect-dim
+ rot gadget-orientation v. min ;
+
+: slider-scale ( slider -- n )
+ #! A scaling factor such that if x is a slider co-ordinate,
+ #! x*n is the screen position of the thumb, and conversely
+ #! for x/n. The '1 max' calls avoid division by zero.
+ dup elevator-length over thumb-dim - 1 max
+ swap slider-max* 1 max / ;
+
+: slider>screen ( m scale -- n ) slider-scale * ;
+: screen>slider ( m scale -- n ) slider-scale / ;
+
+M: slider model-changed nip slider-elevator relayout-1 ;
+
+TUPLE: thumb < gadget ;
+
+: begin-drag ( thumb -- )
+ find-slider dup slider-value swap set-slider-saved ;
+
+: do-drag ( thumb -- )
+ find-slider drag-loc over gadget-orientation v.
+ over screen>slider swap [ slider-saved + ] keep
+ gadget-model set-range-value ;
+
+thumb H{
+ { T{ button-down } [ begin-drag ] }
+ { T{ button-up } [ drop ] }
+ { T{ drag } [ do-drag ] }
+} set-gestures
+
+: thumb-theme ( thumb -- thumb )
+ plain-gradient >>interior
+ faint-boundary ; inline
+
+: <thumb> ( vector -- thumb )
+ thumb new-gadget
+ swap >>orientation
+ t >>root?
+ thumb-theme ;
+
+: slide-by ( amount slider -- ) gadget-model move-by ;
+
+: slide-by-page ( amount slider -- ) gadget-model move-by-page ;
+
+: compute-direction ( elevator -- -1/1 )
+ dup find-slider swap hand-click-rel
+ over gadget-orientation v.
+ over screen>slider
+ swap slider-value - sgn ;
+
+: elevator-hold ( elevator -- )
+ dup elevator-direction swap find-slider slide-by-page ;
+
+: elevator-click ( elevator -- )
+ dup compute-direction over set-elevator-direction
+ elevator-hold ;
+
+elevator H{
+ { T{ drag } [ elevator-hold ] }
+ { T{ button-down } [ elevator-click ] }
+} set-gestures
+
+: <elevator> ( vector -- elevator )
+ elevator new-gadget
+ swap >>orientation
+ lowered-gradient >>interior ;
+
+: (layout-thumb) ( slider n -- n thumb )
+ over gadget-orientation n*v swap slider-thumb ;
+
+: thumb-loc ( slider -- loc )
+ dup slider-value swap slider>screen ;
+
+: layout-thumb-loc ( slider -- )
+ dup thumb-loc (layout-thumb)
+ >r [ floor ] map r> set-rect-loc ;
+
+: layout-thumb-dim ( slider -- )
+ dup dup thumb-dim (layout-thumb) >r
+ >r dup rect-dim r>
+ rot gadget-orientation set-axis [ ceiling ] map
+ r> (>>dim) ;
+
+: layout-thumb ( slider -- )
+ dup layout-thumb-loc layout-thumb-dim ;
+
+M: elevator layout*
+ find-slider layout-thumb ;
+
+: slide-by-line ( amount slider -- )
+ [ slider-line * ] keep slide-by ;
+
+: <slide-button> ( vector polygon amount -- button )
+ >r gray swap <polygon-gadget> r>
+ [ swap find-slider slide-by-line ] curry <repeat-button>
+ [ set-gadget-orientation ] keep ;
+
+: elevator, ( gadget orientation -- gadget )
+ tuck <elevator> >>elevator
+ swap <thumb> >>thumb
+ dup elevator>> over thumb>> add-gadget
+ @center grid-add ;
+
+: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
+: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
+: <up-button> ( -- button ) { 1 0 } arrow-up -1 <slide-button> ;
+: <down-button> ( -- button ) { 1 0 } arrow-down 1 <slide-button> ;
+
+: <slider> ( range orientation -- slider )
+ slider new-frame
+ swap >>orientation
+ swap >>model
+ 32 >>line ;
+
+: <x-slider> ( range -- slider )
+ { 1 0 } <slider>
+ <left-button> @left grid-add
+ { 0 1 } elevator,
+ <right-button> @right grid-add ;
+
+: <y-slider> ( range -- slider )
+ { 0 1 } <slider>
+ <up-button> @top grid-add
+ { 1 0 } elevator,
+ <down-button> @bottom grid-add ;
+
+M: slider pref-dim*
+ dup call-next-method
+ swap gadget-orientation [ 40 v*n ] keep
+ set-axis ;
--- /dev/null
+Slider gadgets provide a graphical view of an integer-valued model
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: ui.gadgets.slots.tests
+USING: assocs ui.gadgets.slots tools.test refs ;
+
+\ <editable-slot> must-infer
+
+[ t ] [ { 1 2 3 } 2 <value-ref> <slot-editor> slot-editor? ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors namespaces kernel parser prettyprint
+sequences arrays io math definitions math.vectors assocs refs
+ui.gadgets ui.gestures ui.commands ui.gadgets.scrollers
+ui.gadgets.buttons ui.gadgets.borders ui.gadgets.tracks
+ui.gadgets.editors eval ;
+IN: ui.gadgets.slots
+
+TUPLE: update-object ;
+
+TUPLE: update-slot ;
+
+TUPLE: edit-slot ;
+
+TUPLE: slot-editor < track ref text ;
+
+: revert ( slot-editor -- )
+ dup slot-editor-ref get-ref unparse-use
+ swap slot-editor-text set-editor-string ;
+
+\ revert H{
+ { +description+ "Revert any uncomitted changes." }
+} define-command
+
+GENERIC: finish-editing ( slot-editor ref -- )
+
+M: key-ref finish-editing
+ drop T{ update-object } swap send-gesture drop ;
+
+M: value-ref finish-editing
+ drop T{ update-slot } swap send-gesture drop ;
+
+: slot-editor-value ( slot-editor -- object )
+ slot-editor-text control-value parse-fresh ;
+
+: commit ( slot-editor -- )
+ dup slot-editor-text control-value parse-fresh first
+ over slot-editor-ref set-ref
+ dup slot-editor-ref finish-editing ;
+
+\ commit H{
+ { +description+ "Parse the object being edited, and store the result back into the edited slot." }
+} define-command
+
+: com-eval ( slot-editor -- )
+ [ slot-editor-text editor-string eval ] keep
+ [ slot-editor-ref set-ref ] keep
+ dup slot-editor-ref finish-editing ;
+
+\ com-eval H{
+ { +listener+ t }
+ { +description+ "Parse code which evaluates to an object, and store the result back into the edited slot." }
+} define-command
+
+: delete ( slot-editor -- )
+ dup slot-editor-ref delete-ref
+ T{ update-object } swap send-gesture drop ;
+
+\ delete H{
+ { +description+ "Delete the slot and close the slot editor." }
+} define-command
+
+: close ( slot-editor -- )
+ T{ update-slot } swap send-gesture drop ;
+
+\ close H{
+ { +description+ "Close the slot editor without saving changes." }
+} define-command
+
+: <slot-editor> ( ref -- gadget )
+ { 0 1 } slot-editor new-track
+ swap >>ref
+ dup <toolbar> f track-add
+ <source-editor> >>text
+ dup text>> <scroller> 1 track-add
+ dup revert ;
+
+M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
+
+M: slot-editor focusable-child* text>> ;
+
+slot-editor "toolbar" f {
+ { T{ key-down f { C+ } "RET" } commit }
+ { T{ key-down f { S+ C+ } "RET" } com-eval }
+ { f revert }
+ { f delete }
+ { T{ key-down f f "ESC" } close }
+} define-command-map
+
+TUPLE: editable-slot < track printer ref ;
+
+: <edit-button> ( -- gadget )
+ "..."
+ [ T{ edit-slot } swap send-gesture drop ]
+ <roll-button> ;
+
+: display-slot ( gadget editable-slot -- )
+ dup clear-track
+ swap 1 track-add
+ <edit-button> f track-add
+ drop ;
+
+: update-slot ( editable-slot -- )
+ [ [ ref>> get-ref ] [ printer>> ] bi call ] keep
+ display-slot ;
+
+: edit-slot ( editable-slot -- )
+ [ clear-track ]
+ [
+ dup ref>> <slot-editor>
+ [ 1 track-add drop ]
+ [ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
+ ] bi ;
+
+\ editable-slot H{
+ { T{ update-slot } [ update-slot ] }
+ { T{ edit-slot } [ edit-slot ] }
+} set-gestures
+
+: <editable-slot> ( gadget ref -- editable-slot )
+ { 1 0 } editable-slot new-track
+ swap >>ref
+ [ drop <gadget> ] >>printer
+ [ display-slot ] keep ;
--- /dev/null
+Slot editor gadgets are used to implement the UI inspector
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax models
+ui.gadgets ui.gadgets.worlds ;
+IN: ui.gadgets.status-bar
+
+HELP: <status-bar>
+{ $values { "model" model } { "gadget" "a new " { $link gadget } } }
+{ $description "Creates a new " { $link gadget } " displaying the model value, which must be a string or " { $link f } "." }
+{ $notes "If the " { $snippet "model" } " is " { $link world-status } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ;
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors models models.delay models.filter
+sequences ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks
+ui.gadgets.worlds ui.gadgets ui kernel calendar summary ;
+IN: ui.gadgets.status-bar
+
+: <status-bar> ( model -- gadget )
+ 1/10 seconds <delay> [ "" like ] <filter> <label-control>
+ reverse-video-theme
+ t >>root? ;
+
+: open-status-window ( gadget title -- )
+ f <model> [ <world> ] keep
+ <status-bar> f track-add
+ open-world-window ;
+
+: show-summary ( object gadget -- )
+ >r [ summary ] [ "" ] if* r> show-status ;
--- /dev/null
+Status bar gadgets display mouse-over help for other gadgets
--- /dev/null
+Gadget hierarchy and layout management
--- /dev/null
+William Schlieper
\ No newline at end of file
--- /dev/null
+Tabbed windows
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: accessors kernel fry math math.vectors sequences arrays vectors assocs\r
+ hashtables models models.range models.compose combinators\r
+ ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs\r
+ ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;\r
+\r
+IN: ui.gadgets.tabs\r
+\r
+TUPLE: tabbed < frame names toggler content ;\r
+\r
+DEFER: (del-page)\r
+\r
+:: add-toggle ( model n name toggler -- )\r
+ <frame>\r
+ n name toggler parent>> '[ , , , (del-page) ] "X" swap <bevel-button>\r
+ @right grid-add\r
+ n model name <toggle-button> @center grid-add\r
+ toggler swap add-gadget drop ;\r
+\r
+: redo-toggler ( tabbed -- )\r
+ [ names>> ] [ model>> ] [ toggler>> ] tri\r
+ [ clear-gadget ] keep\r
+ [ [ length ] keep ] 2dip\r
+ '[ , _ _ , add-toggle ] 2each ;\r
+\r
+: refresh-book ( tabbed -- )\r
+ model>> [ ] change-model ;\r
+\r
+: (del-page) ( n name tabbed -- )\r
+ { [ [ remove ] change-names redo-toggler ]\r
+ [ dupd [ names>> length ] [ model>> ] bi\r
+ [ [ = ] keep swap [ 1- ] when\r
+ [ < ] keep swap [ 1- ] when ] change-model ]\r
+ [ content>> nth-gadget unparent ]\r
+ [ refresh-book ]\r
+ } cleave ;\r
+\r
+: add-page ( page name tabbed -- )\r
+ [ names>> push ] 2keep\r
+ [ [ model>> swap ]\r
+ [ names>> length 1 - swap ]\r
+ [ toggler>> ] tri add-toggle ]\r
+ [ content>> swap add-gadget drop ]\r
+ [ refresh-book ] tri ;\r
+\r
+: del-page ( name tabbed -- )\r
+ [ names>> index ] 2keep (del-page) ;\r
+\r
+: new-tabbed ( assoc class -- tabbed )\r
+ new-frame\r
+ 0 <model> >>model\r
+ <pile> 1 >>fill >>toggler\r
+ dup toggler>> @left grid-add\r
+ swap\r
+ [ keys >vector >>names ]\r
+ [ values over model>> <book> >>content dup content>> @center grid-add ]\r
+ bi\r
+ dup redo-toggler ;\r
+ \r
+: <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;\r
--- /dev/null
+Slava Pestov
--- /dev/null
+Common colors and gradients used by the UI
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2006, 2007 Alex Chapman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel sequences io.styles ui.gadgets ui.render
+colors accessors ;
+IN: ui.gadgets.theme
+
+: solid-interior ( gadget color -- gadget )
+ <solid> >>interior ; inline
+
+: solid-boundary ( gadget color -- gadget )
+ <solid> >>boundary ; inline
+
+: faint-boundary ( gadget -- gadget )
+ gray solid-boundary ; inline
+
+: selection-color ( -- color ) light-purple ;
+
+: plain-gradient
+ T{ gradient f {
+ T{ gray f 0.94 1.0 }
+ T{ gray f 0.83 1.0 }
+ T{ gray f 0.83 1.0 }
+ T{ gray f 0.62 1.0 }
+ } } ;
+
+: rollover-gradient
+ T{ gradient f {
+ T{ gray f 1.0 1.0 }
+ T{ gray f 0.9 1.0 }
+ T{ gray f 0.9 1.0 }
+ T{ gray f 0.75 1.0 }
+ } } ;
+
+: pressed-gradient
+ T{ gradient f {
+ T{ gray f 0.75 1.0 }
+ T{ gray f 0.9 1.0 }
+ T{ gray f 0.9 1.0 }
+ T{ gray f 1.0 1.0 }
+ } } ;
+
+: selected-gradient
+ T{ gradient f {
+ T{ gray f 0.65 1.0 }
+ T{ gray f 0.8 1.0 }
+ T{ gray f 0.8 1.0 }
+ T{ gray f 1.0 1.0 }
+ } } ;
+
+: lowered-gradient
+ T{ gradient f {
+ T{ gray f 0.37 1.0 }
+ T{ gray f 0.43 1.0 }
+ T{ gray f 0.5 1.0 }
+ } } ;
+
+: sans-serif-font { "sans-serif" plain 12 } ;
+
+: monospace-font { "monospace" plain 12 } ;
--- /dev/null
+
+USING: kernel sequences math math.order
+ ui.gadgets ui.gadgets.tracks ui.gestures
+ fry accessors ;
+
+IN: ui.gadgets.tiling
+
+TUPLE: tiling < track gadgets tiles first focused ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-tiling ( tiling -- tiling )
+ init-track
+ { 1 0 } >>orientation
+ V{ } clone >>gadgets
+ 2 >>tiles
+ 0 >>first
+ 0 >>focused ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <tiling> ( -- gadget ) tiling new init-tiling ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bounded-subseq ( seq a b -- seq )
+ [ 0 max ] dip
+ pick length [ min ] curry bi@
+ rot
+ subseq ;
+
+: tiling-gadgets-to-map ( tiling -- gadgets )
+ [ gadgets>> ]
+ [ first>> ]
+ [ [ first>> ] [ tiles>> ] bi + ]
+ tri
+ bounded-subseq ;
+
+: tiling-map-gadgets ( tiling -- tiling )
+ dup clear-track
+ dup tiling-gadgets-to-map [ 1 track-add ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: tiling-add ( tiling gadget -- tiling )
+ over gadgets>> push
+ tiling-map-gadgets ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: first-gadget ( tiling -- index ) drop 0 ;
+
+: last-gadget ( tiling -- index ) gadgets>> length 1 - ;
+
+: first-viewable ( tiling -- index ) first>> ;
+
+: last-viewable ( tiling -- index ) [ first>> ] [ tiles>> ] bi + 1 - ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-focused-mapped ( tiling -- tiling )
+
+ dup [ focused>> ] [ first>> ] bi <
+ [ dup first>> 1 - >>first ]
+ [ ]
+ if
+
+ dup [ last-viewable ] [ focused>> ] bi <
+ [ dup first>> 1 + >>first ]
+ [ ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: check-focused-bounds ( tiling -- tiling )
+ dup focused>> 0 max over gadgets>> length 1 - min >>focused ;
+
+: focus-prev ( tiling -- tiling )
+ dup focused>> 1 - >>focused
+ check-focused-bounds
+ make-focused-mapped
+ tiling-map-gadgets
+ dup request-focus ;
+
+: focus-next ( tiling -- tiling )
+ dup focused>> 1 + >>focused
+ check-focused-bounds
+ make-focused-mapped
+ tiling-map-gadgets
+ dup request-focus ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: exchanged! ( seq a b -- )
+ [ 0 max ] bi@
+ pick length 1 - '[ , min ] bi@
+ rot exchange ;
+
+: move-prev ( tiling -- tiling )
+ dup [ gadgets>> ] [ focused>> 1 - ] [ focused>> ] tri exchanged!
+ focus-prev ;
+
+: move-next ( tiling -- tiling )
+ dup [ gadgets>> ] [ focused>> ] [ focused>> 1 + ] tri exchanged!
+ focus-next ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: add-tile ( tiling -- tiling )
+ dup tiles>> 1 + >>tiles
+ tiling-map-gadgets ;
+
+: del-tile ( tiling -- tiling )
+ dup tiles>> 1 - 1 max >>tiles
+ tiling-map-gadgets ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: tiling focusable-child* ( tiling -- child/t )
+ [ focused>> ] [ gadgets>> ] bi nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: tiling-shelf < tiling ;
+TUPLE: tiling-pile < tiling ;
+
+: <tiling-shelf> ( -- gadget )
+ tiling-shelf new init-tiling { 1 0 } >>orientation ;
+
+: <tiling-pile> ( -- gadget )
+ tiling-pile new init-tiling { 0 1 } >>orientation ;
+
+tiling-shelf
+ H{
+ { T{ key-down f { A+ } "LEFT" } [ focus-prev drop ] }
+ { T{ key-down f { A+ } "RIGHT" } [ focus-next drop ] }
+ { T{ key-down f { S+ A+ } "LEFT" } [ move-prev drop ] }
+ { T{ key-down f { S+ A+ } "RIGHT" } [ move-next drop ] }
+ { T{ key-down f { C+ } "[" } [ del-tile drop ] }
+ { T{ key-down f { C+ } "]" } [ add-tile drop ] }
+ }
+set-gestures
+
+tiling-pile
+ H{
+ { T{ key-down f { A+ } "UP" } [ focus-prev drop ] }
+ { T{ key-down f { A+ } "DOWN" } [ focus-next drop ] }
+ { T{ key-down f { S+ A+ } "UP" } [ move-prev drop ] }
+ { T{ key-down f { S+ A+ } "DOWN" } [ move-next drop ] }
+ { T{ key-down f { C+ } "[" } [ del-tile drop ] }
+ { T{ key-down f { C+ } "]" } [ add-tile drop ] }
+ }
+set-gestures
--- /dev/null
+Slava Pestov
--- /dev/null
+Track gadgets arrange children horizontally or vertically, giving each child a specified fraction of total available space
--- /dev/null
+USING: ui.gadgets.packs help.markup help.syntax ui.gadgets
+arrays kernel quotations classes.tuple ;
+IN: ui.gadgets.tracks
+
+ARTICLE: "ui-track-layout" "Track layouts"
+"Track gadgets are like " { $link "ui-pack-layout" } " except each child is resized to a fixed multiple of the track's dimension."
+{ $subsection track }
+"Creating empty tracks:"
+{ $subsection <track> }
+"Adding children:"
+{ $subsection track-add } ;
+
+HELP: track
+{ $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ;
+
+HELP: <track>
+{ $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }
+{ $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
+
+HELP: track-add
+{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
+{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;
+
+ABOUT: "ui-track-layout"
--- /dev/null
+USING: kernel ui.gadgets ui.gadgets.tracks tools.test
+ math.geometry.rect accessors ;
+IN: ui.gadgets.tracks.tests
+
+[ { 100 100 } ] [
+ { 0 1 } <track>
+ <gadget> { 100 100 } >>dim 1 track-add
+ pref-dim
+] unit-test
+
+[ { 100 110 } ] [
+ { 0 1 } <track>
+ <gadget> { 10 10 } >>dim f track-add
+ <gadget> { 100 100 } >>dim 1 track-add
+ pref-dim
+] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io kernel math namespaces
+ sequences words math.vectors ui.gadgets ui.gadgets.packs
+ math.geometry.rect fry ;
+
+IN: ui.gadgets.tracks
+
+TUPLE: track < pack sizes ;
+
+: normalized-sizes ( track -- seq )
+ sizes>> dup sift sum '[ dup [ , / ] when ] map ;
+
+: init-track ( track -- track )
+ init-gadget
+ V{ } clone >>sizes
+ 1 >>fill ;
+
+: new-track ( orientation class -- track )
+ new
+ init-track
+ swap >>orientation ;
+
+: <track> ( orientation -- track ) track new-track ;
+
+: alloted-dim ( track -- dim )
+ [ children>> ] [ sizes>> ] bi { 0 0 }
+ [ [ drop { 0 0 } ] [ pref-dim ] if v+ ] 2reduce ;
+
+: available-dim ( track -- dim ) [ dim>> ] [ alloted-dim ] bi v- ;
+
+: track-layout ( track -- sizes )
+ [ available-dim ] [ children>> ] [ normalized-sizes ] tri
+ [ [ over n*v ] [ pref-dim ] ?if ] 2map nip ;
+
+M: track layout* ( track -- ) dup track-layout pack-layout ;
+
+: track-pref-dims-1 ( track -- dim ) children>> pref-dims max-dim ;
+
+: track-pref-dims-2 ( track -- dim )
+ [ children>> pref-dims ] [ normalized-sizes ] bi
+ [ [ v/n ] when* ] 2map
+ max-dim
+ [ >fixnum ] map ;
+
+M: track pref-dim* ( gadget -- dim )
+ [ track-pref-dims-1 ]
+ [ [ alloted-dim ] [ track-pref-dims-2 ] bi v+ ]
+ [ orientation>> ]
+ tri
+ set-axis ;
+
+: track-add ( track gadget constraint -- track )
+ pick sizes>> push add-gadget ;
+
+: track-remove ( track gadget -- track )
+ dupd dup
+ [
+ [ swap children>> index ]
+ [ unparent sizes>> ] 2bi
+ delete-nth
+ ]
+ [ 2drop ]
+ if ;
+
+: clear-track ( track -- ) V{ } clone >>sizes clear-gadget ;
--- /dev/null
+Slava Pestov
--- /dev/null
+Viewport gadgets display a portion of a child gadget and are used to implement scrollers
--- /dev/null
+USING: help.markup help.syntax ui.gadgets models ;
+IN: ui.gadgets.viewports
+
+HELP: viewport
+{ $class-description "A viewport is a control which positions a child gadget translated by the " { $link control-value } " vector. Viewports can be created directly by calling " { $link <viewport> } "." } ;
+
+HELP: <viewport>
+{ $values { "content" gadget } { "model" model } { "viewport" "a new " { $link viewport } } }
+{ $description "Creates a new " { $link viewport } " containing " { $snippet "content" } "." } ;
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: ui.gadgets.viewports
+USING: accessors arrays ui.gadgets ui.gadgets.borders
+kernel math namespaces sequences models math.vectors math.geometry.rect ;
+
+: viewport-gap { 3 3 } ; inline
+
+TUPLE: viewport < gadget ;
+
+: find-viewport ( gadget -- viewport )
+ [ viewport? ] find-parent ;
+
+: viewport-dim ( viewport -- dim )
+ gadget-child pref-dim viewport-gap 2 v*n v+ ;
+
+: <viewport> ( content model -- viewport )
+ viewport new-gadget
+ swap >>model
+ t >>clipped?
+ [ swap add-gadget drop ] keep ;
+
+M: viewport layout*
+ dup rect-dim viewport-gap 2 v*n v-
+ over gadget-child pref-dim vmax
+ swap gadget-child (>>dim) ;
+
+M: viewport focusable-child*
+ gadget-child ;
+
+M: viewport pref-dim* viewport-dim ;
+
+: scroller-value ( scroller -- loc )
+ gadget-model range-value [ >fixnum ] map ;
+
+M: viewport model-changed
+ nip
+ dup relayout-1
+ dup scroller-value
+ vneg viewport-gap v+
+ swap gadget-child set-rect-loc ;
+
+: visible-dim ( gadget -- dim )
+ dup gadget-parent viewport? [
+ gadget-parent rect-dim viewport-gap 2 v*n v-
+ ] [
+ rect-dim
+ ] if ;
--- /dev/null
+Slava Pestov
--- /dev/null
+World gadgets are the top level of the gadget hierarchy and are displayed in native windows
--- /dev/null
+USING: ui.gadgets ui.render ui.gestures ui.backend help.markup
+help.syntax models opengl strings ;
+IN: ui.gadgets.worlds
+
+HELP: origin
+{ $var-description "Within the dynamic extent of " { $link draw-world } ", holds the co-ordinate system origin for the gadget currently being drawn." } ;
+
+HELP: hand-world
+{ $var-description "Global variable. The " { $link world } " containing the gadget at the mouse location." } ;
+
+HELP: set-title
+{ $values { "string" string } { "world" world } }
+{ $description "Sets the title bar of the native window containing the world." }
+{ $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ;
+
+HELP: select-gl-context
+{ $values { "handle" "a backend-specific handle" } }
+{ $description "Selects an OpenGL context to be the implicit destination for subsequent GL rendering calls. This word is called automatically by the UI before drawing a " { $link world } "." } ;
+
+HELP: flush-gl-context
+{ $values { "handle" "a backend-specific handle" } }
+{ $description "Ensures all GL rendering calls made to an OpenGL context finish rendering to the screen. This word is called automatically by the UI after drawing a " { $link world } "." } ;
+
+HELP: focus-path
+{ $values { "world" world } { "seq" "a new sequence" } }
+{ $description "If the top-level window containing the world has focus, outputs a sequence of parents of the currently focused gadget, otherwise outputs " { $link f } "." }
+{ $notes "This word is used to avoid sending " { $link gain-focus } " gestures to a gadget which requests focus on an unfocused top-level window, so that, for instance, a text editing caret does not appear in this case." } ;
+
+HELP: world
+{ $class-description "A gadget which appears at the top of the gadget hieararchy, and in turn may be displayed in a native window. Worlds have the following slots:"
+ { $list
+ { { $snippet "active?" } " - if set to " { $link f } ", the world will not be drawn. This slot is set to " { $link f } " if an error is thrown while drawing the world; this prevents multiple debugger windows from being shown." }
+ { { $snippet "glass" } " - a glass pane in front of the primary gadget, used to implement behaviors such as popup menus which are hidden when the mouse is clicked outside the menu." }
+ { { $snippet "title" } " - a string to be displayed in the title bar of the native window containing the world." }
+ { { $snippet "status" } " - a " { $link model } " holding a string to be displayed in the world's status bar." }
+ { { $snippet "focus" } " - the current owner of the keyboard focus in the world." }
+ { { $snippet "focused?" } " - a boolean indicating if the native window containing the world has keyboard focus." }
+ { { $snippet "fonts" } " - a hashtable mapping font instances to vectors of " { $link sprite } " instances." }
+ { { $snippet "handle" } " - a backend-specific native handle representing the native window containing the world, or " { $link f } " if the world is not grafted." }
+ { { $snippet "window-loc" } " - the on-screen location of the native window containing the world. The co-ordinate system here is backend-specific." }
+ }
+} ;
+
+HELP: <world>
+{ $values { "gadget" gadget } { "title" string } { "status" model } { "world" "a new " { $link world } } }
+{ $description "Creates a new " { $link world } " delegating to the given gadget." } ;
+
+HELP: find-world
+{ $values { "gadget" gadget } { "world" "a " { $link world } " or " { $link f } } }
+{ $description "Finds the " { $link world } " containing the gadget, or outputs " { $link f } " if the gadget is not grafted." } ;
+
+HELP: draw-world
+{ $values { "world" world } }
+{ $description "Redraws a world." }
+{ $notes "This word should only be called by the UI backend. To force a gadget to redraw from user code, call " { $link relayout-1 } "." } ;
--- /dev/null
+IN: ui.gadgets.worlds.tests
+USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
+namespaces models kernel ;
+
+! Test focus behavior
+<gadget> "g1" set
+
+: <test-world> ( gadget -- world )
+ "Hi" f <world> ;
+
+[ ] [
+ "g1" get <test-world> "w" set
+] unit-test
+
+[ ] [ "g1" get request-focus ] unit-test
+
+[ t ] [ "w" get gadget-focus "g1" get eq? ] unit-test
+
+<gadget> "g1" set
+<gadget> "g2" set
+"g1" get "g2" get swap add-gadget drop
+
+[ ] [
+ "g2" get <test-world> "w" set
+] unit-test
+
+[ ] [ "g1" get request-focus ] unit-test
+
+[ t ] [ "w" get gadget-focus "g2" get eq? ] unit-test
+[ t ] [ "g2" get gadget-focus "g1" get eq? ] unit-test
+[ f ] [ "g1" get gadget-focus ] unit-test
+
+<gadget> "g1" set
+<gadget> "g2" set
+<gadget> "g3" set
+"g1" get "g3" get swap add-gadget drop
+"g2" get "g3" get swap add-gadget drop
+
+[ ] [
+ "g3" get <test-world> "w" set
+] unit-test
+
+[ ] [ "g1" get request-focus ] unit-test
+[ ] [ "g2" get unparent ] unit-test
+[ t ] [ "g3" get gadget-focus "g1" get eq? ] unit-test
+
+[ t ] [ <gadget> dup <test-world> focusable-child eq? ] unit-test
+
+TUPLE: focusing < gadget ;
+
+: <focusing>
+ focusing new-gadget ;
+
+TUPLE: focus-test < gadget ;
+
+: <focus-test>
+ focus-test new-gadget
+ <focusing> over swap add-gadget drop ;
+
+M: focus-test focusable-child* gadget-child ;
+
+<focus-test> "f" set
+
+[ ] [ "f" get <test-world> request-focus ] unit-test
+
+[ t ] [ "f" get gadget-focus "f" get gadget-child eq? ] unit-test
+
+[ t ] [ "f" get gadget-child focusing? ] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs continuations kernel math models
+namespaces opengl sequences io combinators math.vectors
+ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
+debugger math.geometry.rect ;
+IN: ui.gadgets.worlds
+
+TUPLE: world < track
+active? focused?
+glass
+title status
+fonts handle
+window-loc ;
+
+: find-world ( gadget -- world ) [ world? ] find-parent ;
+
+M: f world-status ;
+
+: show-status ( string/f gadget -- )
+ find-world world-status [ set-model ] [ drop ] if* ;
+
+: hide-status ( gadget -- ) f swap show-status ;
+
+: (request-focus) ( child world ? -- )
+ pick gadget-parent pick eq? [
+ >r >r dup gadget-parent dup r> r>
+ [ (request-focus) ] keep
+ ] unless focus-child ;
+
+M: world request-focus-on ( child gadget -- )
+ 2dup eq?
+ [ 2drop ] [ dup world-focused? (request-focus) ] if ;
+
+: <world> ( gadget title status -- world )
+ { 0 1 } world new-track
+ t >>root?
+ t >>active?
+ H{ } clone >>fonts
+ { 0 0 } >>window-loc
+ swap >>status
+ swap >>title
+ swap 1 track-add
+ dup request-focus ;
+
+M: world layout*
+ dup call-next-method
+ dup world-glass [
+ >r dup rect-dim r> (>>dim)
+ ] when* drop ;
+
+M: world focusable-child* gadget-child ;
+
+M: world children-on nip gadget-children ;
+
+: (draw-world) ( world -- )
+ dup world-handle [
+ [ dup init-gl ] keep draw-gadget
+ ] with-gl-context ;
+
+: draw-world? ( world -- ? )
+ #! We don't draw deactivated worlds, or those with 0 size.
+ #! On Windows, the latter case results in GL errors.
+ dup world-active?
+ over world-handle
+ rot rect-dim [ 0 > ] all? and and ;
+
+TUPLE: world-error error world ;
+
+C: <world-error> world-error
+
+SYMBOL: ui-error-hook
+
+: ui-error ( error -- )
+ ui-error-hook get [ call ] [ print-error ] if* ;
+
+[ rethrow ] ui-error-hook set-global
+
+: draw-world ( world -- )
+ dup draw-world? [
+ dup world [
+ [
+ (draw-world)
+ ] [
+ over <world-error> ui-error
+ f swap set-world-active?
+ ] recover
+ ] with-variable
+ ] [
+ drop
+ ] if ;
+
+world H{
+ { T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] }
+ { T{ key-down f { C+ } "c" } [ T{ copy-action } send-action ] }
+ { T{ key-down f { C+ } "v" } [ T{ paste-action } send-action ] }
+ { T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] }
+ { T{ button-down f { C+ } 1 } [ T{ button-down f f 3 } swap resend-button-down ] }
+ { T{ button-down f { A+ } 1 } [ T{ button-down f f 2 } swap resend-button-down ] }
+ { T{ button-up f { C+ } 1 } [ T{ button-up f f 3 } swap resend-button-up ] }
+ { T{ button-up f { A+ } 1 } [ T{ button-up f f 2 } swap resend-button-up ] }
+} set-gestures
+
+: close-global ( world global -- )
+ dup get-global find-world rot eq?
+ [ f swap set-global ] [ drop ] if ;
--- /dev/null
+! 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 ;
+
+: <wrapper> ( child -- border ) wrapper new-wrapper ;
+
+M: wrapper pref-dim* ( wrapper -- dim ) gadget-child pref-dim ;
+
+M: wrapper layout* ( wrapper -- ) [ dim>> ] [ gadget-child ] bi (>>dim) ;
+
+M: wrapper focusable-child* ( wrapper -- child/t ) gadget-child ;
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets help.markup help.syntax hashtables
+strings kernel system ;
+IN: ui.gestures
+
+HELP: set-gestures
+{ $values { "class" "a class word" } { "hash" hashtable } }
+{ $description "Sets the gestures a gadget class responds to. The hashtable maps gestures to quotations with stack effect " { $snippet "( gadget -- )" } "." } ;
+
+HELP: handle-gesture*
+{ $values { "gadget" "the receiver of the gesture" } { "gesture" "a gesture" } { "delegate" "an object" } { "?" "a boolean" } }
+{ $contract "Handles a gesture sent to a gadget. As the delegation chain is traversed, this generic word is called with every delegate of the gadget at the top of the stack, however the front-most delegate remains fixed as the " { $snippet "gadget" } " parameter."
+$nl
+"Outputs " { $link f } " if the gesture was handled, and " { $link t } " if the gesture should be passed on to the gadget's delegate." }
+{ $notes "Methods should be defined on this word if you desire to handle an arbitrary set of gestures. To define handlers for a fixed set, it is easier to use " { $link set-gestures } "." } ;
+
+HELP: handle-gesture
+{ $values { "gesture" "a gesture" } { "gadget" gadget } { "?" "a boolean" } }
+{ $description "Calls " { $link handle-gesture* } " on every delegate of " { $snippet "gadget" } ". Outputs " { $link f } " if some delegate handled the gesture, else outputs " { $link t } "." } ;
+
+{ send-gesture handle-gesture handle-gesture* set-gestures } related-words
+
+HELP: send-gesture
+{ $values { "gesture" "a gesture" } { "gadget" gadget } { "?" "a boolean" } }
+{ $description "Calls " { $link send-gesture } " on every parent of " { $snippet "gadget" } ". Outputs " { $link f } " if some parent handled the gesture, else outputs " { $link t } "." } ;
+
+HELP: user-input
+{ $values { "str" string } { "gadget" gadget } }
+{ $description "Calls " { $link user-input* } " on every parent of the gadget." } ;
+
+HELP: motion
+{ $class-description "Mouse motion gesture." }
+{ $examples { $code "T{ motion }" } } ;
+
+HELP: drag
+{ $class-description "Mouse drag gesture. The " { $link drag-# } " slot is either set to a mouse button number, or " { $link f } " indicating no specific button is expected." } ;
+
+HELP: button-up
+{ $class-description "Mouse button up gesture. Instances have two slots:"
+ { $list
+ { { $link button-up-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
+ { { $link button-up-# } " - a mouse button number, or " { $link f } " indicating no specific button is expected" }
+ }
+}
+{ $examples { $code "T{ button-up f f 1 }" "T{ button-up }" } } ;
+
+HELP: button-down
+{ $class-description "Mouse button down gesture. Instances have two slots:"
+ { $list
+ { { $link button-down-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
+ { { $link button-down-# } " - a mouse button number, or " { $link f } " indicating no specific button is expected" }
+ }
+}
+{ $examples { $code "T{ button-down f f 1 }" "T{ button-down }" } } ;
+
+HELP: mouse-scroll
+{ $class-description "Scroll wheel motion gesture. When this gesture is sent, the " { $link scroll-direction } " global variable is set to a direction vector." }
+{ $examples { $code "T{ mouse-scroll }" } } ;
+
+HELP: mouse-enter
+{ $class-description "Gesture sent when the mouse enters the bounds of a gadget." }
+{ $examples { $code "T{ mouse-enter }" } } ;
+
+HELP: mouse-leave
+{ $class-description "Gesture sent when the mouse leaves the bounds of a gadget." }
+{ $examples { $code "T{ mouse-leave }" } } ;
+
+HELP: gain-focus
+{ $class-description "Gesture sent when a gadget gains keyboard focus." }
+{ $examples { $code "T{ gain-focus }" } } ;
+
+HELP: lose-focus
+{ $class-description "Gesture sent when a gadget loses keyboard focus." }
+{ $examples { $code "T{ lose-focus }" } } ;
+
+HELP: cut-action
+{ $class-description "Gesture sent when the " { $emphasis "cut" } " standard window system action is invoked." }
+{ $examples { $code "T{ cut-action }" } } ;
+
+HELP: copy-action
+{ $class-description "Gesture sent when the " { $emphasis "copy" } " standard window system action is invoked." }
+{ $examples { $code "T{ copy-action }" } } ;
+
+HELP: paste-action
+{ $class-description "Gesture sent when the " { $emphasis "paste" } " standard window system action is invoked." }
+{ $examples { $code "T{ paste-action }" } } ;
+
+HELP: delete-action
+{ $class-description "Gesture sent when the " { $emphasis "delete" } " standard window system action is invoked." }
+{ $examples { $code "T{ delete-action }" } } ;
+
+HELP: select-all-action
+{ $class-description "Gesture sent when the " { $emphasis "select all" } " standard window system action is invoked." }
+{ $examples { $code "T{ select-all-action }" } } ;
+
+HELP: generalize-gesture
+{ $values { "gesture" "a gesture" } { "newgesture" "a new gesture" } }
+{ $description "Turns a " { $link button-down } ", " { $link button-up } " or " { $link drag } " action naming a specific mouse button into one which can apply regardless of which mouse button was pressed." } ;
+
+HELP: C+
+{ $description "Control key modifier." } ;
+
+HELP: A+
+{ $description "Alt key modifier." } ;
+
+HELP: M+
+{ $description "Meta key modifier. This is the Command key on Mac OS X." } ;
+
+HELP: S+
+{ $description "Shift key modifier." } ;
+
+HELP: key-down
+{ $class-description "Key down gesture. Instances have two slots:"
+ { $list
+ { { $link key-down-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
+ { { $link key-down-sym } " - a string denoting the key pressed; see " { $link "keyboard-gestures" } }
+ }
+}
+{ $examples { $code "T{ key-down f { C+ } \"a\" }" "T{ key-down f f \"TAB\" }" } } ;
+
+HELP: key-up
+{ $class-description "Key up gesture. Instances have two slots:"
+ { $list
+ { { $link key-up-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
+ { { $link key-up-sym } " - a string denoting the key pressed; see " { $link "keyboard-gestures" } }
+ }
+}
+{ $examples { $code "T{ key-up f { C+ } \"a\" }" "T{ key-up f f \"TAB\" }" } } ;
+
+HELP: hand-gadget
+{ $var-description "Global variable. The gadget at the mouse location." } ;
+
+HELP: hand-loc
+{ $var-description "Global variable. The mouse location relative to the top-left corner of the " { $link hand-world } "." } ;
+
+{ hand-loc hand-rel } related-words
+
+HELP: hand-clicked
+{ $var-description "Global variable. The gadget at the location of the most recent click." } ;
+
+HELP: hand-click-loc
+{ $var-description "Global variable. The mouse location at the time of the most recent click relative to the top-left corner of the " { $link hand-world } "." } ;
+
+{ hand-clicked hand-click-loc } related-words
+
+HELP: hand-click#
+{ $var-description "Global variable. The number of times the mouse was clicked in short succession. This counter is reset when " { $link double-click-timeout } " expires." } ;
+
+HELP: hand-last-button
+{ $var-description "Global variable. The mouse button most recently pressed." } ;
+
+HELP: hand-last-time
+{ $var-description "Global variable. The timestamp of the most recent mouse button click. This timestamp has the same format as the output value of " { $link millis } "." } ;
+
+HELP: hand-buttons
+{ $var-description "Global variable. A vector of mouse buttons currently held down." } ;
+
+HELP: scroll-direction
+{ $var-description "Global variable. If the most recent gesture was a " { $link mouse-scroll } ", this holds a pair of integers indicating the direction of the scrolling as a two-dimensional vector." } ;
+
+HELP: double-click-timeout
+{ $var-description "Global variable. The maximum delay between two button presses which will still increment " { $link hand-click# } "." } ;
+
+HELP: button-gesture
+{ $values { "gesture" "a gesture" } }
+{ $description "Sends a gesture to the most recently clicked gadget, and if the gadget does not respond to the gesture, removes specific button number information from the gesture and sends it again." } ;
+
+HELP: fire-motion
+{ $description "Sends a " { $link motion } " or " { $link drag } " gesture to the gadget under the mouse, depending on whether a mouse button is being held down or not." } ;
+
+HELP: forget-rollover
+{ $description "Sends " { $link mouse-leave } " gestures to all gadgets containing the gadget under the mouse, and resets the " { $link hand-gadget } " variable." } ;
+
+HELP: request-focus
+{ $values { "gadget" gadget } }
+{ $description "Gives keyboard focus to the " { $link focusable-child } " of the gadget. This may result in " { $link lose-focus } " and " { $link gain-focus } " gestures being sent." } ;
+
+HELP: drag-loc
+{ $values { "loc" "a pair of integers" } }
+{ $description "Outputs the distance travelled by the mouse since the most recent press. Only meaningful inside a " { $link drag } " gesture handler." } ;
+
+HELP: hand-rel
+{ $values { "gadget" gadget } { "loc" "a pair of integers" } }
+{ $description "Outputs the location of the mouse relative to the top-left corner of the gadget. Only meaningful inside a " { $link button-down } ", " { $link button-up } ", " { $link motion } " or " { $link drag } " gesture handler, where the gadget is contained in the same world as the gadget receiving the gesture." } ;
+
+HELP: hand-click-rel
+{ $values { "gadget" gadget } { "loc" "a pair of integers" } }
+{ $description "Outputs the location of the last mouse relative to the top-left corner of the gadget. Only meaningful inside a " { $link button-down } ", " { $link button-up } ", " { $link motion } " or " { $link drag } " gesture handler, where the gadget is contained in the same world as the gadget receiving the gesture." } ;
+
+HELP: under-hand
+{ $values { "seq" "a new sequence" } }
+{ $description "Outputs a sequence where the first element is the " { $link hand-world } " and the last is the " { $link hand-gadget } ", with all parents in between." } ;
+
+HELP: gesture>string
+{ $values { "gesture" "a gesture" } { "string/f" "a " { $link string } " or " { $link f } } }
+{ $contract "Creates a human-readable string from a gesture object, returning " { $link f } " if the gesture does not have a human-readable form." }
+{ $examples
+ { $example "USING: io ui.gestures ;" "T{ key-down f { C+ } \"x\" } gesture>string print" "C+x" }
+} ;
+
+ARTICLE: "ui-gestures" "UI gestures"
+"User actions such as keyboard input and mouse button clicks deliver " { $emphasis "gestures" } " to gadgets. If the direct receiver of the gesture does not handle it, the gesture is passed on to the receiver's parent, and this way it travels up the gadget hierarchy. Gestures which are not handled at some point are ignored."
+$nl
+"There are two ways to define gesture handling logic. The simplest way is to associate a fixed set of gestures with a class:"
+{ $subsection set-gestures }
+"Another way is to define a generic word on a class which handles all gestures sent to gadgets of that class:"
+{ $subsection handle-gesture* }
+"Sometimes a gesture needs to be presented to the user:"
+{ $subsection gesture>string }
+"Keyboard input:"
+{ $subsection "ui-focus" }
+{ $subsection "keyboard-gestures" }
+{ $subsection "action-gestures" }
+{ $subsection "ui-user-input" }
+"Mouse input:"
+{ $subsection "mouse-gestures" }
+"Abstractions built on top of gestures:"
+{ $subsection "ui-commands" }
+{ $subsection "ui-operations" } ;
+
+ARTICLE: "ui-focus" "Keyboard focus"
+"The gadget with keyboard focus is the current receiver of keyboard gestures and user input. Gadgets that wish to receive keyboard input should request focus when clicked:"
+{ $subsection request-focus }
+"The following example demonstrates defining a handler for a mouse click gesture which requests focus:"
+{ $code
+ "my-gadget H{"
+ " { T{ button-down } [ request-focus ] }"
+ "} set-gestures"
+}
+"To nominate a single child as the default focusable child, implement a method on a generic word:"
+{ $subsection focusable-child* }
+"Gestures are sent to a gadget when it gains or loses focus; this can be used to change the gadget's appearance, for example by displaying a border:"
+{ $subsection gain-focus }
+{ $subsection lose-focus } ;
+
+ARTICLE: "keyboard-gestures" "Keyboard gestures"
+"There are two types of keyboard gestures:"
+{ $subsection key-down }
+{ $subsection key-up }
+"Each keyboard gesture has a set of modifiers and a key symbol. The set modifiers is denoted by an array which must either be " { $link f } ", or an order-preserving subsequence of the following:"
+{ $code "{ S+ C+ A+ M+ }" }
+{ $subsection S+ }
+{ $subsection C+ }
+{ $subsection A+ }
+{ $subsection M+ }
+"A key symbol is either a single-character string denoting literal input, or one of the following strings:"
+{ $list
+ { $snippet "CLEAR" }
+ { $snippet "RET" }
+ { $snippet "ENTER" }
+ { $snippet "ESC" }
+ { $snippet "TAB" }
+ { $snippet "BACKSPACE" }
+ { $snippet "HOME" }
+ { $snippet "DELETE" }
+ { $snippet "END" }
+ { $snippet "F1" }
+ { $snippet "F2" }
+ { $snippet "F3" }
+ { $snippet "F4" }
+ { $snippet "F5" }
+ { $snippet "F6" }
+ { $snippet "F7" }
+ { $snippet "F8" }
+ { $snippet "LEFT" }
+ { $snippet "RIGHT" }
+ { $snippet "DOWN" }
+ { $snippet "UP" }
+ { $snippet "PAGE_UP" }
+ { $snippet "PAGE_DOWN" }
+}
+"The " { $link S+ } " modifier is only ever used with the above action keys; alphanumeric input input with the shift key is delivered without the " { $link S+ } " modifier set, instead the input itself is upper case. For example, the gesture corresponding to " { $snippet "s" } " with the Control and Shift keys pressed is presented as "
+{ $code "T{ key-down f { C+ } \"S\" }" }
+"The " { $snippet "RET" } ", " { $snippet "TAB" } " and " { $snippet "SPACE" } " keys are never delivered in their literal form (" { $snippet "\"\\n\"" } ", " { $snippet "\"\\t\"" } " or " { $snippet "\" \"" } ")." ;
+
+ARTICLE: "ui-user-input" "Free-form keyboard input"
+"Whereas keyboard gestures are intended to be used for keyboard shortcuts, certain gadgets such as text fields need to accept free-form keyboard input. This can be done by implementing a generic word:"
+{ $subsection user-input* } ;
+
+ARTICLE: "mouse-gestures" "Mouse gestures"
+"There are two types of mouse gestures indicating button clicks:"
+{ $subsection button-down }
+{ $subsection button-up }
+"When a mouse button is pressed or released, two gestures are sent. The first gesture indicates the specific button number, and if this gesture is not handled, the second has a button number set to " { $link f } ":"
+{ $code "T{ button-down f 1 }" "T{ button-down f f }" }
+"Because tuple literals fill unspecified slots with " { $link f } ", the last gesture can be written as " { $snippet "T{ button-down }" } "."
+$nl
+"Gestures to indicate mouse motion, depending on whenever a button is held down or not:"
+{ $subsection motion }
+{ $subsection drag }
+"Gestures to indicate that the mouse has crossed gadget boundaries:"
+{ $subsection mouse-enter }
+{ $subsection mouse-leave }
+"A number of global variables are set after a mouse gesture is sent. These variables can be read to obtain additional information about the gesture."
+{ $subsection hand-gadget }
+{ $subsection hand-world }
+{ $subsection hand-loc }
+{ $subsection hand-buttons }
+{ $subsection hand-clicked }
+{ $subsection hand-click-loc }
+{ $subsection hand-click# }
+"There are some utility words for working with click locations:"
+{ $subsection hand-rel }
+{ $subsection hand-click-rel }
+{ $subsection drag-loc }
+"Mouse scroll wheel gesture:"
+{ $subsection mouse-scroll }
+"Global variable set when a mouse scroll wheel gesture is sent:"
+{ $subsection scroll-direction } ;
+
+ARTICLE: "action-gestures" "Action gestures"
+"Action gestures exist to keep keyboard shortcuts for common clipboard operations consistent."
+{ $subsection cut-action }
+{ $subsection copy-action }
+{ $subsection paste-action }
+{ $subsection delete-action }
+{ $subsection select-all-action }
+"The following keyboard gestures, if not handled directly, send action gestures:"
+{ $table
+ { { $strong "Keyboard gesture" } { $strong "Action gesture" } }
+ { { $snippet "T{ key-down f { C+ } \"x\" }" } { $snippet "T{ cut-action }" } }
+ { { $snippet "T{ key-down f { C+ } \"c\" }" } { $snippet "T{ copy-action }" } }
+ { { $snippet "T{ key-down f { C+ } \"v\" }" } { $snippet "T{ paste-action }" } }
+ { { $snippet "T{ key-down f { C+ } \"a\" }" } { $snippet "T{ select-all }" } }
+}
+"Action gestures should be used in place of the above keyboard gestures if possible. For example, on Mac OS X, the standard " { $strong "Edit" } " menu items send action gestures." ;
+
+ABOUT: "ui-gestures"
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs kernel math models namespaces
+sequences words strings system hashtables math.parser
+math.vectors classes.tuple classes ui.gadgets boxes
+calendar alarms symbols combinators sets columns ;
+IN: ui.gestures
+
+: set-gestures ( class hash -- ) "gestures" set-word-prop ;
+
+GENERIC: handle-gesture* ( gadget gesture delegate -- ? )
+
+: default-gesture-handler ( gadget gesture delegate -- ? )
+ class superclasses [ "gestures" word-prop ] map assoc-stack dup
+ [ call f ] [ 2drop t ] if ;
+
+M: object handle-gesture* default-gesture-handler ;
+
+: handle-gesture ( gesture gadget -- ? )
+ tuck delegates [ >r 2dup r> handle-gesture* ] all? 2nip ;
+
+: send-gesture ( gesture gadget -- ? )
+ [ dupd handle-gesture ] each-parent nip ;
+
+: user-input ( str gadget -- )
+ over empty?
+ [ [ dupd user-input* ] each-parent ] unless
+ 2drop ;
+
+! Gesture objects
+TUPLE: motion ; C: <motion> motion
+TUPLE: drag # ; C: <drag> drag
+TUPLE: button-up mods # ; C: <button-up> button-up
+TUPLE: button-down mods # ; C: <button-down> button-down
+TUPLE: mouse-scroll ; C: <mouse-scroll> mouse-scroll
+TUPLE: mouse-enter ; C: <mouse-enter> mouse-enter
+TUPLE: mouse-leave ; C: <mouse-leave> mouse-leave
+TUPLE: lose-focus ; C: <lose-focus> lose-focus
+TUPLE: gain-focus ; C: <gain-focus> gain-focus
+
+! Higher-level actions
+TUPLE: cut-action ; C: <cut-action> cut-action
+TUPLE: copy-action ; C: <copy-action> copy-action
+TUPLE: paste-action ; C: <paste-action> paste-action
+TUPLE: delete-action ; C: <delete-action> delete-action
+TUPLE: select-all-action ; C: <select-all-action> select-all-action
+
+TUPLE: left-action ; C: <left-action> left-action
+TUPLE: right-action ; C: <right-action> right-action
+TUPLE: up-action ; C: <up-action> up-action
+TUPLE: down-action ; C: <down-action> down-action
+
+TUPLE: zoom-in-action ; C: <zoom-in-action> zoom-in-action
+TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
+
+: generalize-gesture ( gesture -- newgesture )
+ clone f >># ;
+
+! Modifiers
+SYMBOLS: C+ A+ M+ S+ ;
+
+TUPLE: key-down mods sym ;
+
+: <key-gesture> ( mods sym action? class -- mods' sym' )
+ >r [ S+ rot remove swap ] unless r> boa ; inline
+
+: <key-down> ( mods sym action? -- key-down )
+ key-down <key-gesture> ;
+
+TUPLE: key-up mods sym ;
+
+: <key-up> ( mods sym action? -- key-up )
+ key-up <key-gesture> ;
+
+! Hand state
+
+! Note that these are only really useful inside an event
+! handler, and that the locations hand-loc and hand-click-loc
+! are in the co-ordinate system of the world which contains
+! the gadget in question.
+SYMBOL: hand-gadget
+SYMBOL: hand-world
+SYMBOL: hand-loc
+{ 0 0 } hand-loc set-global
+
+SYMBOL: hand-clicked
+SYMBOL: hand-click-loc
+SYMBOL: hand-click#
+SYMBOL: hand-last-button
+SYMBOL: hand-last-time
+0 hand-last-button set-global
+0 hand-last-time set-global
+
+SYMBOL: hand-buttons
+V{ } clone hand-buttons set-global
+
+SYMBOL: scroll-direction
+{ 0 0 } scroll-direction set-global
+
+SYMBOL: double-click-timeout
+300 double-click-timeout set-global
+
+: hand-moved? ( -- ? )
+ hand-loc get hand-click-loc get = not ;
+
+: button-gesture ( gesture -- )
+ hand-clicked get-global 2dup send-gesture [
+ >r generalize-gesture r> send-gesture drop
+ ] [
+ 2drop
+ ] if ;
+
+: drag-gesture ( -- )
+ hand-buttons get-global
+ dup empty? [ drop ] [ first <drag> button-gesture ] if ;
+
+SYMBOL: drag-timer
+
+<box> drag-timer set-global
+
+: start-drag-timer ( -- )
+ hand-buttons get-global empty? [
+ [ drag-gesture ]
+ 300 milliseconds hence
+ 100 milliseconds
+ add-alarm drag-timer get-global >box
+ ] when ;
+
+: stop-drag-timer ( -- )
+ hand-buttons get-global empty? [
+ drag-timer get-global ?box
+ [ cancel-alarm ] [ drop ] if
+ ] when ;
+
+: fire-motion ( -- )
+ hand-buttons get-global empty? [
+ T{ motion } hand-gadget get-global send-gesture drop
+ ] [
+ drag-gesture
+ ] if ;
+
+: each-gesture ( gesture seq -- )
+ [ handle-gesture drop ] with each ;
+
+: hand-gestures ( new old -- )
+ drop-prefix <reversed>
+ T{ mouse-leave } swap each-gesture
+ T{ mouse-enter } swap each-gesture ;
+
+: forget-rollover ( -- )
+ f hand-world set-global
+ hand-gadget get-global >r
+ f hand-gadget set-global
+ f r> parents hand-gestures ;
+
+: send-lose-focus ( gadget -- )
+ T{ lose-focus } swap handle-gesture drop ;
+
+: send-gain-focus ( gadget -- )
+ T{ gain-focus } swap handle-gesture drop ;
+
+: focus-child ( child gadget ? -- )
+ [
+ dup gadget-focus [
+ dup send-lose-focus
+ f swap t focus-child
+ ] when*
+ dupd set-gadget-focus [
+ send-gain-focus
+ ] when*
+ ] [
+ set-gadget-focus
+ ] if ;
+
+: modifier ( mod modifiers -- seq )
+ [ second swap bitand 0 > ] with filter
+ 0 <column> prune dup empty? [ drop f ] [ >array ] if ;
+
+: drag-loc ( -- loc )
+ hand-loc get-global hand-click-loc get-global v- ;
+
+: hand-rel ( gadget -- loc )
+ hand-loc get-global swap screen-loc v- ;
+
+: hand-click-rel ( gadget -- loc )
+ hand-click-loc get-global swap screen-loc v- ;
+
+: multi-click-timeout? ( -- ? )
+ millis hand-last-time get - double-click-timeout get <= ;
+
+: multi-click-button? ( button -- button ? )
+ dup hand-last-button get = ;
+
+: multi-click-position? ( -- ? )
+ hand-loc get hand-click-loc get v- norm-sq 100 <= ;
+
+: multi-click? ( button -- ? )
+ {
+ { [ multi-click-timeout? not ] [ f ] }
+ { [ multi-click-button? not ] [ f ] }
+ { [ multi-click-position? not ] [ f ] }
+ { [ multi-click-position? not ] [ f ] }
+ [ t ]
+ } cond nip ;
+
+: update-click# ( button -- )
+ global [
+ dup multi-click? [
+ hand-click# inc
+ ] [
+ 1 hand-click# set
+ ] if
+ hand-last-button set
+ millis hand-last-time set
+ ] bind ;
+
+: update-clicked ( -- )
+ hand-gadget get-global hand-clicked set-global
+ hand-loc get-global hand-click-loc set-global ;
+
+: under-hand ( -- seq )
+ hand-gadget get-global parents <reversed> ;
+
+: move-hand ( loc world -- )
+ dup hand-world set-global
+ under-hand >r over hand-loc set-global
+ pick-up hand-gadget set-global
+ under-hand r> hand-gestures ;
+
+: send-button-down ( gesture loc world -- )
+ move-hand
+ start-drag-timer
+ dup button-down-#
+ dup update-click# hand-buttons get-global push
+ update-clicked
+ button-gesture ;
+
+: send-button-up ( gesture loc world -- )
+ move-hand
+ dup button-up-# hand-buttons get-global delete
+ stop-drag-timer
+ button-gesture ;
+
+: send-wheel ( direction loc world -- )
+ move-hand
+ scroll-direction set-global
+ T{ mouse-scroll } hand-gadget get-global send-gesture
+ drop ;
+
+: world-focus ( world -- gadget )
+ dup gadget-focus [ world-focus ] [ ] ?if ;
+
+: send-action ( world gesture -- )
+ swap world-focus send-gesture drop ;
+
+: resend-button-down ( gesture world -- )
+ hand-loc get-global swap send-button-down ;
+
+: resend-button-up ( gesture world -- )
+ hand-loc get-global swap send-button-up ;
+
+GENERIC: gesture>string ( gesture -- string/f )
+
+: modifiers>string ( modifiers -- string )
+ [ name>> ] map concat >string ;
+
+M: key-down gesture>string
+ dup key-down-mods modifiers>string
+ swap key-down-sym append ;
+
+M: button-up gesture>string
+ [
+ dup button-up-mods modifiers>string %
+ "Click Button" %
+ button-up-# [ " " % # ] when*
+ ] "" make ;
+
+M: button-down gesture>string
+ [
+ dup button-down-mods modifiers>string %
+ "Press Button" %
+ button-down-# [ " " % # ] when*
+ ] "" make ;
+
+M: left-action gesture>string drop "Swipe left" ;
+
+M: right-action gesture>string drop "Swipe right" ;
+
+M: up-action gesture>string drop "Swipe up" ;
+
+M: down-action gesture>string drop "Swipe down" ;
+
+M: zoom-in-action gesture>string drop "Zoom in" ;
+
+M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
+
+M: object gesture>string drop f ;
--- /dev/null
+Translating window system events to gestures, and delivering gestures to gadgets
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.commands help.markup help.syntax ui.gadgets words
+kernel hashtables strings classes quotations sequences
+ui.gestures ;
+IN: ui.operations
+
+: $operations ( element -- )
+ >quotation call
+ f f operations>commands
+ command-map. ;
+
+: $operation ( element -- )
+ first +keyboard+ word-prop gesture>string $snippet ;
+
+HELP: +keyboard+
+{ $description "A key which may be set in the hashtable passed to " { $link define-operation } ". The value is a gesture." } ;
+
+HELP: +primary+
+{ $description "A key which may be set in the hashtable passed to " { $link define-operation } ". If set to a true value, this operation becomes the default operation performed when a presentation matching the operation's predicate is clicked with the mouse." } ;
+
+HELP: operation
+{ $description "An abstraction for an operation which may be performed on a presentation."
+$nl
+"Operations have the following slots:"
+{ $list
+ { { $link operation-predicate } " - a quotation with stack effect " { $snippet "( obj -- ? )" } }
+ { { $link operation-command } " - a " { $link word } }
+ { { $link operation-translator } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
+ { { $link operation-hook } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
+ { { $link operation-listener? } " - a boolean" }
+} } ;
+
+HELP: operation-gesture
+{ $values { "operation" operation } { "gesture" "a gesture or " { $link f } } }
+{ $description "Outputs the keyboard gesture associated with the operation." } ;
+
+HELP: operations
+{ $var-description "Global variable holding a vector of " { $link operation } " instances. New operations can be added with " { $link define-operation } "." } ;
+
+HELP: object-operations
+{ $values { "obj" object } { "operations" "a sequence of " { $link operation } " instances" } }
+{ $description "Outputs a sequence of operations applicable to the given object, by testing each defined operation's " { $link operation-predicate } " quotation in turn." } ;
+
+HELP: primary-operation
+{ $values { "obj" object } { "operation" "an " { $link operation } " or " { $link f } } }
+{ $description "Outputs the operation which should be invoked when a presentation of " { $snippet "obj" } " is clicked." } ;
+
+HELP: secondary-operation
+{ $values { "obj" object } { "operation" "an " { $link operation } " or " { $link f } } }
+{ $description "Outputs the operation which should be invoked when a " { $snippet "RET" } " is pressed while a presentation of " { $snippet "obj" } " is selected in a list." } ;
+
+HELP: define-operation
+{ $values { "pred" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "command" word } { "flags" hashtable } }
+{ $description "Defines an operation on objects matching the predicate. The hashtable can contain the following keys:"
+ { $list
+ { { $link +listener+ } " - if set to a true value, the operation will run in the listener" }
+ { { $link +description+ } " - can be set to a string description of the operation" }
+ { { $link +primary+ } " - if set to a true value, the operation will be output by " { $link primary-operation } " when applied to an object satisfying the predicate" }
+ { { $link +secondary+ } " - if set to a true value, the operation will be output by " { $link secondary-operation } " when applied to an object satisfying the predicate" }
+ { { $link +keyboard+ } " - can be set to a keyboard gesture; the guesture will be used by " { $link define-operation-map } }
+ }
+} ;
+
+HELP: define-operation-map
+{ $values { "class" "a class word" } { "group" string } { "blurb" "a " { $link string } " or " { $link f } } { "object" object } { "hook" "a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } { "translator" "a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } }
+{ $description "Defines a command map named " { $snippet "group" } " on " { $snippet "class" } " consisting of operations applicable to " { $snippet "object" } ". The hook quotation is applied to the target gadget; the translator quotation is applied to the result of the hook. Finally the result of the translator is passed to the operation. A distinction is drawn between the hook and the translator because for listener operations, the hook runs in the event loop and the translator runs in the listener. This avoids polluting the listener output with large prettyprinted gadgets and long quotations." } ;
+
+HELP: $operations
+{ $values { "element" "a sequence" } }
+{ $description "Converts the element to a quotation and calls it; the resulting quotation must have stack effect " { $snippet "( -- obj )" } ". Prints a list of operations applicable to the object, together with keyboard shortcuts." } ;
+
+HELP: $operation
+{ $values { "element" "a sequence containing a single word" } }
+{ $description "Prints the keyboard shortcut associated with the word, which must have been previously defined as an operation by a call to " { $link define-operation } "." } ;
+
+ARTICLE: "ui-operations" "Operations"
+"Operations are commands performed on presentations."
+{ $subsection operation }
+{ $subsection define-operation }
+{ $subsection primary-operation }
+{ $subsection secondary-operation }
+{ $subsection define-operation-map }
+"When documenting gadgets, operation documentation can be automatically generated:"
+{ $subsection $operations }
+{ $subsection $operation } ;
+
+ABOUT: "ui-operations"
--- /dev/null
+IN: ui.operations.tests
+USING: ui.operations ui.commands prettyprint kernel namespaces
+tools.test ui.gadgets ui.gadgets.editors parser io
+io.streams.string math help help.markup ;
+
+: my-pprint pprint ;
+
+[ drop t ] \ my-pprint [ ] [ ] f operation boa "op" set
+
+[ [ 3 my-pprint ] ] [
+ 3 "op" get operation-command command-quot
+] unit-test
+
+[ "3" ] [ [ 3 "op" get invoke-command ] with-string-writer ] unit-test
+
+[ drop t ] \ my-pprint [ ] [ editor-string ] f operation boa
+"op" set
+
+[ "\"4\"" ] [
+ [
+ "4" <editor> [ set-editor-string ] keep
+ "op" get invoke-command
+ ] with-string-writer
+] unit-test
+
+[ ] [
+ [ { $operations \ + } print-element ] with-string-writer drop
+] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays definitions kernel ui.commands
+ui.gestures sequences strings math words generic namespaces
+hashtables help.markup quotations assocs ;
+IN: ui.operations
+
+SYMBOL: +keyboard+
+SYMBOL: +primary+
+SYMBOL: +secondary+
+
+TUPLE: operation predicate command translator hook listener? ;
+
+: <operation> ( predicate command -- operation )
+ operation new
+ [ ] >>hook
+ [ ] >>translator
+ swap >>command
+ swap >>predicate ;
+
+PREDICATE: listener-operation < operation
+ dup operation-command listener-command?
+ swap operation-listener? or ;
+
+M: operation command-name
+ operation-command command-name ;
+
+M: operation command-description
+ operation-command command-description ;
+
+M: operation command-word operation-command command-word ;
+
+: operation-gesture ( operation -- gesture )
+ operation-command +keyboard+ word-prop ;
+
+SYMBOL: operations
+
+: object-operations ( obj -- operations )
+ operations get [ operation-predicate call ] with filter ;
+
+: find-operation ( obj quot -- command )
+ >r object-operations r> find-last nip ; inline
+
+: primary-operation ( obj -- operation )
+ [ operation-command +primary+ word-prop ] find-operation ;
+
+: secondary-operation ( obj -- operation )
+ dup
+ [ operation-command +secondary+ word-prop ] find-operation
+ [ ] [ primary-operation ] ?if ;
+
+: default-flags ( -- assoc )
+ H{ { +keyboard+ f } { +primary+ f } { +secondary+ f } } ;
+
+: define-operation ( pred command flags -- )
+ default-flags swap assoc-union
+ dupd define-command <operation>
+ operations get push ;
+
+: modify-operation ( hook translator operation -- operation )
+ clone
+ tuck set-operation-translator
+ tuck set-operation-hook
+ t over set-operation-listener? ;
+
+: modify-operations ( operations hook translator -- operations )
+ rot [ >r 2dup r> modify-operation ] map 2nip ;
+
+: operations>commands ( object hook translator -- pairs )
+ >r >r object-operations r> r> modify-operations
+ [ [ operation-gesture ] keep ] { } map>assoc ;
+
+: define-operation-map ( class group blurb object hook translator -- )
+ operations>commands define-command-map ;
+
+: operation-quot ( target command -- quot )
+ [
+ swap literalize ,
+ dup operation-translator %
+ operation-command ,
+ ] [ ] make ;
+
+M: operation invoke-command ( target command -- )
+ [ operation-hook call ] keep operation-quot call ;
--- /dev/null
+Operations are commands which may be performed on a presentation's underlying object
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets ui.gestures help.markup help.syntax
+kernel classes strings opengl.gl models math.geometry.rect ;
+IN: ui.render
+
+HELP: gadget
+{ $class-description "An object which displays itself on the screen and acts on user input gestures. Gadgets have the following slots:"
+ { $list
+ { { $snippet "pref-dim" } " - a cached value for " { $link pref-dim } "; do not read or write this slot directly." }
+ { { $snippet "parent" } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
+ { { $snippet "children" } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
+ { { $snippet "orientation" } " - an orientation specifier. This slot is used by layout gadgets." }
+ { { $snippet "layout-state" } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
+ { { $snippet "visible?" } " - a boolean indicating if the gadget should display and receive user input." }
+ { { $snippet "root?" } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
+ { { $snippet "clipped?" } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
+ { { $snippet "interior" } " - an object whose class implements the " { $link draw-interior } " generic word." }
+ { { $snippet "boundary" } " - an object whose class implements the " { $link draw-boundary } " generic word." }
+ { { $snippet "model" } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
+ }
+"Gadgets subclass the " { $link rect } " class, and thus all instances have " { $snippet "loc" } " and " { $snippet "dim" } " instances holding their location and dimensions." }
+{ $notes
+"Other classes may inherit from " { $link gadget } " in order to re-implement generic words such as " { $link draw-gadget* } " and " { $link user-input* } ", or to define gestures with " { $link set-gestures } "." } ;
+
+HELP: clip
+{ $var-description "The current clipping rectangle." } ;
+
+HELP: draw-gadget*
+{ $values { "gadget" gadget } }
+{ $contract "Draws the gadget by making OpenGL calls. The top-left corner of the gadget should be drawn at the location stored in the " { $link origin } " variable." }
+{ $notes "This word should not be called directly. To force a gadget to redraw, call " { $link relayout-1 } "." } ;
+
+HELP: draw-interior
+{ $values { "interior" object } { "gadget" gadget } }
+{ $contract "Draws the interior of a gadget by making OpenGL calls. The " { $link gadget-interior } " slot may be set to objects implementing this generic word." } ;
+
+HELP: draw-boundary
+{ $values { "boundary" object } { "gadget" gadget } }
+{ $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $link gadget-boundary } " slot may be set to objects implementing this generic word." } ;
+
+HELP: solid
+{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid fill, respectively. The " { $link solid-color } " slot stores a color specifier." } ;
+
+HELP: gradient
+{ $class-description "A class implementing the " { $link draw-interior } " generic word to draw a smoothly shaded transition between colors. The " { $link gradient-colors } " slot stores a sequence of color specifiers and the gradient is drawn in the direction given by the " { $link gadget-orientation } " slot of the gadget." } ;
+
+HELP: polygon
+{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid filled polygon, respectively. Instances of " { $link polygon } " have two slots:"
+ { $list
+ { { $link polygon-color } " - a color specifier" }
+ { { $link polygon-points } " - a sequence of points" }
+ }
+} ;
+
+HELP: <polygon>
+{ $values { "color" "a color specifier" } { "points" "a sequence of points" } }
+{ $description "Creates a new instance of " { $link polygon } "." } ;
+
+HELP: <polygon-gadget>
+{ $values { "color" "a color specifier" } { "points" "a sequence of points" } { "gadget" "a new " { $link gadget } } }
+{ $description "Creates a gadget which is drawn as a solid filled polygon. The gadget's size is the minimum bounding box containing all the points of the polygon." } ;
+
+HELP: open-font
+{ $values { "font" "a font specifier" } { "open-font" object } }
+{ $description "Loads a font if it has not already been loaded, otherwise outputs the existing font." }
+{ $errors "Throws an error if the font does not exist." } ;
+
+HELP: string-width
+{ $values { "open-font" "a value output by " { $link open-font } } { "string" string } { "w" "a positive integer" } }
+{ $description "Outputs the width of a string." } ;
+
+HELP: text-dim
+{ $values { "open-font" "a value output by " { $link open-font } } { "text" "a string or an array of strings" } { "dim" "a pair of integers" } }
+{ $description "Outputs the dimensions of a piece of text, which is either a single-line string or an array of lines." } ;
+
+HELP: draw-string
+{ $values { "font" "a font specifier" } { "string" string } { "loc" "a pair of integers" } }
+{ $description "Draws a line of text." } ;
+
+HELP: draw-text
+{ $values { "font" "a font specifier" } { "text" "a string or an array of strings" } { "loc" "a pair of integers" } }
+{ $description "Draws text. Text is either a single-line string or an array of lines." } ;
+
+ARTICLE: "gadgets-polygons" "Polygon gadgets"
+"A polygon gadget renders a simple shaded polygon."
+{ $subsection <polygon-gadget> }
+"Some pre-made polygons:"
+{ $subsection arrow-up }
+{ $subsection arrow-right }
+{ $subsection arrow-down }
+{ $subsection arrow-left }
+{ $subsection close-box }
+"Polygon gadgets are rendered by the " { $link polygon } " pen protocol implementation." ;
+
+ARTICLE: "ui-paint" "Customizing gadget appearance"
+"The UI carries out the following steps when drawing a gadget:"
+{ $list
+ { "The " { $link draw-interior } " generic word is called on the value of the " { $link gadget-interior } " slot." }
+ { "The " { $link draw-gadget* } " generic word is called on the gadget." }
+ { "The gadget's visible children are drawn, determined by calling " { $link visible-children } " on the gadget." }
+ { "The " { $link draw-boundary } " generic word is called on the value of the " { $link gadget-boundary } " slot." }
+}
+"Now, each one of these steps will be covered in detail."
+{ $subsection "ui-pen-protocol" }
+{ $subsection "ui-paint-custom" } ;
+
+ARTICLE: "ui-pen-protocol" "UI pen protocol"
+"The " { $link gadget-interior } " and " { $link gadget-boundary } " slots of a gadget facilitate easy factoring and sharing of drawing logic. Objects stored in these slots must implement the pen protocol:"
+{ $subsection draw-interior }
+{ $subsection draw-boundary }
+"The default value of these slots is the " { $link f } " singleton, which implements the above protocol by doing nothing."
+$nl
+"Some other pre-defined implementations:"
+{ $subsection solid }
+{ $subsection gradient }
+{ $subsection polygon }
+"Custom implementations must follow the guidelines set forth in " { $link "ui-paint-custom" } "." ;
+
+ARTICLE: "text-rendering" "Rendering text"
+"Unlike OpenGL, Factor's FreeType binding only includes the bare essentials, and there is rarely any need to directly call words in the " { $vocab-link "freetype" } " vocabulary directly. Instead, the UI provides high-level wrappers."
+$nl
+"Font objects are never constructed directly, and instead are obtained by calling a word:"
+{ $subsection open-font }
+"Measuring text:"
+{ $subsection text-dim }
+{ $subsection text-height }
+{ $subsection text-width }
+"Rendering text:"
+{ $subsection draw-string }
+{ $subsection draw-text } ;
+
+ARTICLE: "ui-paint-custom" "Implementing custom drawing logic"
+"The UI uses OpenGL to render gadgets. Custom rendering logic can be plugged in with the " { $link "ui-pen-protocol" } ", or by implementing a generic word:"
+{ $subsection draw-gadget* }
+"Custom drawing code has access to the full OpenGL API in the " { $vocab-link "opengl" } " vocabulary."
+$nl
+"The UI uses a co-ordinate system where the y axis is oriented down. The OpenGL " { $link GL_MODELVIEW } " matrix is not saved or restored when rendering a gadget. Instead, the origin of the gadget relative to the OpenGL context is stored in a variable:"
+{ $subsection origin }
+"Custom drawing implementations can translate co-ordinates manually, or save and restore the " { $link GL_MODELVIEW } " matrix."
+$nl
+"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa."
+$nl
+"Gadgets must not draw outside of their bounding box, however clipping is not enforced by default, for performance reasons. This can be changed by setting the " { $link gadget-clipped? } " slot to " { $link t } " in the gadget's constructor."
+$nl
+"Saving the " { $link GL_MODELVIEW } " matrix and enabling/disabling flags can be done in a clean way using the combinators documented in the following section."
+{ $subsection "gl-utilities" }
+{ $subsection "text-rendering" } ;
+
+ABOUT: "ui-paint-custom"
--- /dev/null
+! Copyright (C) 2005, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien arrays hashtables io kernel math namespaces opengl
+opengl.gl opengl.glu sequences strings io.styles vectors
+combinators math.vectors ui.gadgets colors
+math.order math.geometry.rect ;
+IN: ui.render
+
+SYMBOL: clip
+
+SYMBOL: viewport-translation
+
+: flip-rect ( rect -- loc dim )
+ rect-bounds [
+ >r { 1 -1 } v* r> { 0 -1 } v* v+
+ viewport-translation get v+
+ ] keep ;
+
+: do-clip ( -- ) clip get flip-rect gl-set-clip ;
+
+: init-clip ( clip-rect rect -- )
+ GL_SCISSOR_TEST glEnable
+ [ rect-intersect ] keep
+ rect-dim dup { 0 1 } v* viewport-translation set
+ { 0 0 } over gl-viewport
+ 0 swap first2 0 gluOrtho2D
+ clip set
+ do-clip ;
+
+: init-gl ( clip-rect rect -- )
+ GL_SMOOTH glShadeModel
+ GL_BLEND glEnable
+ GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
+ init-matrices
+ init-clip
+ ! white gl-clear is broken w.r.t window resizing
+ ! Linux/PPC Radeon 9200
+ white set-color
+ clip get rect-extent gl-fill-rect ;
+
+GENERIC: draw-gadget* ( gadget -- )
+
+M: gadget draw-gadget* drop ;
+
+GENERIC: draw-interior ( gadget interior -- )
+
+GENERIC: draw-boundary ( gadget boundary -- )
+
+SYMBOL: origin
+
+{ 0 0 } origin set-global
+
+: visible-children ( gadget -- seq )
+ clip get origin get vneg offset-rect swap children-on ;
+
+: translate ( rect/point -- ) rect-loc origin [ v+ ] change ;
+
+DEFER: draw-gadget
+
+: (draw-gadget) ( gadget -- )
+ [
+ dup translate
+ dup dup gadget-interior draw-interior
+ dup draw-gadget*
+ dup visible-children [ draw-gadget ] each
+ dup gadget-boundary draw-boundary
+ ] with-scope ;
+
+: >absolute ( rect -- rect )
+ origin get offset-rect ;
+
+: change-clip ( gadget -- )
+ >absolute clip [ rect-intersect ] change ;
+
+: with-clipping ( gadget quot -- )
+ clip get >r
+ over change-clip do-clip call
+ r> clip set do-clip ; inline
+
+: draw-gadget ( gadget -- )
+ {
+ { [ dup gadget-visible? not ] [ drop ] }
+ { [ dup gadget-clipped? not ] [ (draw-gadget) ] }
+ [ [ (draw-gadget) ] with-clipping ]
+ } cond ;
+
+! Pen paint properties
+M: f draw-interior 2drop ;
+M: f draw-boundary 2drop ;
+
+! Solid fill/border
+TUPLE: solid color ;
+
+C: <solid> solid
+
+! Solid pen
+: (solid) ( gadget paint -- loc dim )
+ solid-color set-color rect-dim >r origin get dup r> v+ ;
+
+M: solid draw-interior (solid) gl-fill-rect ;
+
+M: solid draw-boundary (solid) gl-rect ;
+
+! Gradient pen
+TUPLE: gradient colors ;
+
+C: <gradient> gradient
+
+M: gradient draw-interior
+ origin get [
+ over gadget-orientation
+ swap gradient-colors
+ rot rect-dim
+ gl-gradient
+ ] with-translation ;
+
+! Polygon pen
+TUPLE: polygon color points ;
+
+C: <polygon> polygon
+
+: draw-polygon ( polygon quot -- )
+ origin get [
+ >r dup polygon-color set-color polygon-points r> call
+ ] with-translation ; inline
+
+M: polygon draw-boundary
+ [ gl-poly ] draw-polygon drop ;
+
+M: polygon draw-interior
+ [ gl-fill-poly ] draw-polygon drop ;
+
+: arrow-up { { 3 0 } { 6 6 } { 0 6 } } ;
+: arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;
+: arrow-down { { 0 0 } { 6 0 } { 3 6 } } ;
+: arrow-left { { 0 3 } { 6 0 } { 6 6 } } ;
+: close-box { { 0 0 } { 6 0 } { 6 6 } { 0 6 } } ;
+
+: <polygon-gadget> ( color points -- gadget )
+ dup max-dim
+ >r <polygon> <gadget> r> over set-rect-dim
+ [ set-gadget-interior ] keep ;
+
+! Font rendering
+SYMBOL: font-renderer
+
+HOOK: open-font font-renderer ( font -- open-font )
+
+HOOK: string-width font-renderer ( open-font string -- w )
+
+HOOK: string-height font-renderer ( open-font string -- h )
+
+HOOK: draw-string font-renderer ( font string loc -- )
+
+HOOK: x>offset font-renderer ( x open-font string -- n )
+
+HOOK: free-fonts font-renderer ( world -- )
+
+: text-height ( open-font text -- n )
+ dup string? [
+ string-height
+ ] [
+ [ string-height ] with map sum
+ ] if ;
+
+: text-width ( open-font text -- n )
+ dup string? [
+ string-width
+ ] [
+ 0 -rot [ string-width max ] with each
+ ] if ;
+
+: text-dim ( open-font text -- dim )
+ [ text-width ] 2keep text-height 2array ;
+
+: draw-text ( font text loc -- )
+ over string? [
+ draw-string
+ ] [
+ [
+ [
+ 2dup { 0 0 } draw-string
+ >r open-font r> string-height
+ 0.0 swap 0.0 glTranslated
+ ] with each
+ ] with-translation
+ ] if ;
--- /dev/null
+Support for rendering gadgets via OpenGL
--- /dev/null
+Factor's graphical user interface framework
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: ui.tools.browser.tests
+USING: tools.test tools.test.ui ui.tools.browser ;
+
+\ <browser-gadget> must-infer
+[ ] [ <browser-gadget> [ ] with-grafted-gadget ] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: debugger ui.tools.workspace help help.topics kernel
+models models.history ui.commands ui.gadgets ui.gadgets.panes
+ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
+ui.gadgets.buttons compiler.units assocs words vocabs
+accessors ;
+IN: ui.tools.browser
+
+TUPLE: browser-gadget < track pane history ;
+
+: show-help ( link help -- )
+ dup history>> add-history
+ >r >link r> history>> set-model ;
+
+: <help-pane> ( browser-gadget -- gadget )
+ history>> [ [ help ] curry try ] <pane-control> ;
+
+: init-history ( browser-gadget -- )
+ "handbook" >link <history> >>history drop ;
+
+: <browser-gadget> ( -- gadget )
+ { 0 1 } browser-gadget new-track
+ dup init-history
+ dup <toolbar> f track-add
+ dup <help-pane> >>pane
+ dup pane>> <scroller> 1 track-add ;
+
+M: browser-gadget call-tool* show-help ;
+
+M: browser-gadget tool-scroller
+ pane>> find-scroller ;
+
+M: browser-gadget graft*
+ [ add-definition-observer ] [ call-next-method ] bi ;
+
+M: browser-gadget ungraft*
+ [ call-next-method ] [ remove-definition-observer ] bi ;
+
+: showing-definition? ( defspec assoc -- ? )
+ [ key? ] 2keep
+ [ >r dup word-link? [ link-name ] when r> key? ] 2keep
+ >r dup vocab-link? [ vocab ] when r> key?
+ or or ;
+
+M: browser-gadget definitions-changed ( assoc browser -- )
+ history>>
+ dup model-value rot showing-definition?
+ [ notify-connections ] [ drop ] if ;
+
+: help-action ( browser-gadget -- link )
+ history>> model-value >link ;
+
+: com-follow ( link -- ) browser-gadget call-tool ;
+
+: com-back ( browser -- ) history>> go-back ;
+
+: com-forward ( browser -- ) history>> go-forward ;
+
+: com-documentation ( browser -- ) "handbook" swap show-help ;
+
+: com-vocabularies ( browser -- ) "vocab-index" swap show-help ;
+
+: browser-help ( -- ) "ui-browser" help-window ;
+
+\ browser-help H{ { +nullary+ t } } define-command
+
+browser-gadget "toolbar" f {
+ { T{ key-down f { A+ } "b" } com-back }
+ { T{ key-down f { A+ } "f" } com-forward }
+ { T{ key-down f { A+ } "h" } com-documentation }
+ { T{ key-down f { A+ } "v" } com-vocabularies }
+ { T{ key-down f f "F1" } browser-help }
+} define-command-map
+
+browser-gadget "multi-touch" f {
+ { T{ left-action } com-back }
+ { T{ right-action } com-forward }
+} define-command-map
--- /dev/null
+Graphical help browser
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets help.markup help.syntax kernel quotations
+continuations debugger ui ;
+IN: ui.tools.debugger
+
+HELP: <debugger>
+{ $values { "error" "an error" } { "restarts" "a sequence of " { $link restart } " instances" } { "restart-hook" "a quotation with stack effect " { $snippet "( list -- )" } } { "gadget" "a new " { $link gadget } } }
+{ $description
+ "Creates a gadget displaying a description of the error, along with buttons to print the contents of the stacks in the listener, and a list of restarts."
+} ;
+
+{ <debugger> debugger-window ui-try } related-words
+
+HELP: debugger-window
+{ $values { "error" "an error" } }
+{ $description "Opens a window with a description of the error." } ;
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays ui ui.commands ui.gestures ui.gadgets
+ ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
+ ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
+ ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
+ ui.gadgets.scrollers ui.gadgets.panes hashtables io kernel math
+ models namespaces sequences sequences words continuations
+ debugger prettyprint ui.tools.traceback help editors ;
+
+IN: ui.tools.debugger
+
+: <restart-list> ( restarts restart-hook -- gadget )
+ [ restart-name ] rot <model> <list> ;
+
+TUPLE: debugger < track restarts ;
+
+: <debugger-display> ( restart-list error -- gadget )
+ <filled-pile>
+ <pane>
+ swapd tuck [ print-error ] with-pane
+ add-gadget
+
+ swap add-gadget ;
+
+: <debugger> ( error restarts restart-hook -- gadget )
+ { 0 1 } debugger new-track
+ dup <toolbar> f track-add
+ -rot <restart-list> >>restarts
+ dup restarts>> rot <debugger-display> <scroller> 1 track-add ;
+
+M: debugger focusable-child* debugger-restarts ;
+
+: debugger-window ( error -- )
+ #! No restarts for the debugger window
+ f [ drop ] <debugger> "Error" open-window ;
+
+[ debugger-window ] ui-error-hook set-global
+
+M: world-error error.
+ "An error occurred while drawing the world " write
+ dup world>> pprint-short "." print
+ "This world has been deactivated to prevent cascading errors." print
+ error>> error. ;
+
+debugger "gestures" f {
+ { T{ button-down } request-focus }
+} define-command-map
+
+: com-traceback ( -- ) error-continuation get traceback-window ;
+
+\ com-traceback H{ { +nullary+ t } } define-command
+
+\ :help H{ { +nullary+ t } { +listener+ t } } define-command
+
+\ :edit H{ { +nullary+ t } { +listener+ t } } define-command
+
+debugger "toolbar" f {
+ { T{ key-down f f "s" } com-traceback }
+ { T{ key-down f f "h" } :help }
+ { T{ key-down f f "e" } :edit }
+} define-command-map
--- /dev/null
+Graphical error display
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax ;
+IN: ui.tools.deploy
+
+HELP: deploy-tool
+{ $values { "vocab" "a vocabulary specifier" } }
+{ $description "Opens the graphical deployment tool for the specified vocabulary." }
+{ $examples { $code "\"tetris\" deploy-tool" } } ;
+
+ARTICLE: "ui.tools.deploy" "Application deployment UI tool"
+"The application deployment UI tool provides a graphical front-end to deployment configuration. Using the tool, you can set deployment options graphically."
+$nl
+"To start the tool, pass a vocabulary name to a word:"
+{ $subsection deploy-tool }
+"Alternatively, right-click on a vocabulary presentation in the UI and choose " { $strong "Deploy tool" } " from the resulting popup menu."
+{ $see-also "tools.deploy" } ;
+
+ABOUT: "ui.tools.deploy"
--- /dev/null
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ui.gadgets colors kernel ui.render namespaces
+ models models.mapping sequences ui.gadgets.buttons
+ ui.gadgets.packs ui.gadgets.labels tools.deploy.config
+ namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
+ ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
+ tools.deploy vocabs ui.tools.workspace system accessors ;
+
+IN: ui.tools.deploy
+
+TUPLE: deploy-gadget < pack vocab settings ;
+
+: bundle-name ( parent -- parent )
+ deploy-name get <field>
+ "Executable name:" label-on-left add-gadget ;
+
+: deploy-ui ( parent -- parent )
+ deploy-ui? get
+ "Include user interface framework" <checkbox> add-gadget ;
+
+: exit-when-windows-closed ( parent -- parent )
+ "stop-after-last-window?" get
+ "Exit when last UI window closed" <checkbox> add-gadget ;
+
+: io-settings ( parent -- parent )
+ "Input/output support:" <label> add-gadget
+ deploy-io get deploy-io-options <radio-buttons> add-gadget ;
+
+: reflection-settings ( parent -- parent )
+ "Reflection support:" <label> add-gadget
+ deploy-reflection get deploy-reflection-options <radio-buttons> add-gadget ;
+
+: advanced-settings ( parent -- parent )
+ "Advanced:" <label> add-gadget
+ deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
+ deploy-math? get "Rational and complex number support" <checkbox> add-gadget
+ deploy-threads? get "Threading support" <checkbox> add-gadget
+ deploy-random? get "Random number generator support" <checkbox> add-gadget
+ deploy-word-props? get "Retain all word properties" <checkbox> add-gadget
+ deploy-word-defs? get "Retain all word definitions" <checkbox> add-gadget
+ deploy-c-types? get "Retain all C types" <checkbox> add-gadget ;
+
+: deploy-settings-theme ( gadget -- gadget )
+ { 10 10 } >>gap
+ 1 >>fill ;
+
+: <deploy-settings> ( vocab -- control )
+ default-config [ <model> ] assoc-map
+ [
+ <pile>
+ bundle-name
+ deploy-ui
+ os macosx? [ exit-when-windows-closed ] when
+ io-settings
+ reflection-settings
+ advanced-settings
+
+ deploy-settings-theme
+ namespace <mapping> over set-gadget-model
+ ]
+ bind ;
+
+: find-deploy-gadget ( gadget -- deploy-gadget )
+ [ deploy-gadget? ] find-parent ;
+
+: find-deploy-vocab ( gadget -- vocab )
+ find-deploy-gadget deploy-gadget-vocab ;
+
+: find-deploy-config ( gadget -- config )
+ find-deploy-vocab deploy-config ;
+
+: find-deploy-settings ( gadget -- settings )
+ find-deploy-gadget deploy-gadget-settings ;
+
+: com-revert ( gadget -- )
+ dup find-deploy-config
+ swap find-deploy-settings set-control-value ;
+
+: com-save ( gadget -- )
+ dup find-deploy-settings control-value
+ swap find-deploy-vocab set-deploy-config ;
+
+: com-deploy ( gadget -- )
+ dup com-save
+ dup find-deploy-vocab [ deploy ] curry call-listener
+ close-window ;
+
+: com-help ( -- )
+ "ui.tools.deploy" help-window ;
+
+\ com-help H{
+ { +nullary+ t }
+} define-command
+
+: com-close ( gadget -- )
+ close-window ;
+
+deploy-gadget "toolbar" f {
+ { f com-close }
+ { f com-help }
+ { f com-revert }
+ { f com-save }
+ { T{ key-down f f "RET" } com-deploy }
+} define-command-map
+
+: <deploy-gadget> ( vocab -- gadget )
+ deploy-gadget new-gadget
+ over >>vocab
+ { 0 1 } >>orientation
+ swap <deploy-settings> >>settings
+ dup settings>> add-gadget
+ dup <toolbar> { 10 10 } >>gap add-gadget
+ deploy-settings-theme
+ dup com-revert ;
+
+: deploy-tool ( vocab -- )
+ vocab-name dup <deploy-gadget> 10 <border>
+ "Deploying \"" rot "\"" 3append open-window ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors ui.tools.workspace inspector kernel ui.commands
+ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
+ui.gadgets.slots ui.gadgets.tracks ui.gestures
+ui.gadgets.buttons namespaces ;
+IN: ui.tools.inspector
+
+TUPLE: inspector-gadget < track object pane ;
+
+: refresh ( inspector -- )
+ [ object>> ] [ pane>> ] bi [
+ +editable+ on
+ +number-rows+ on
+ describe
+ ] with-pane ;
+
+: <inspector-gadget> ( -- gadget )
+ { 0 1 } inspector-gadget new-track
+ dup <toolbar> f track-add
+ <pane> >>pane
+ dup pane>> <scroller> 1 track-add ;
+
+: inspect-object ( obj mirror keys inspector -- )
+ 2nip swap >>object refresh ;
+
+\ &push H{ { +nullary+ t } { +listener+ t } } define-command
+
+\ &back H{ { +nullary+ t } { +listener+ t } } define-command
+
+\ &globals H{ { +nullary+ t } { +listener+ t } } define-command
+
+: inspector-help ( -- ) "ui-inspector" help-window ;
+
+\ inspector-help H{ { +nullary+ t } } define-command
+
+inspector-gadget "toolbar" f {
+ { T{ update-object } refresh }
+ { f &push }
+ { f &back }
+ { f &globals }
+ { T{ key-down f f "F1" } inspector-help }
+} define-command-map
+
+inspector-gadget "multi-touch" f {
+ { T{ left-action } &back }
+} define-command-map
+
+M: inspector-gadget tool-scroller
+ inspector-gadget-pane find-scroller ;
--- /dev/null
+Graphical object viewer and editor
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets ui.gadgets.editors listener io help.syntax
+help.markup ;
+IN: ui.tools.interactor
+
+HELP: interactor
+{ $class-description "An interactor is an " { $link editor } " intended to be used as the input component of a " { $link "ui-listener" } "."
+$nl
+"Interactors are created by calling " { $link <interactor> } "."
+$nl
+"Interactors implement the " { $link stream-readln } ", " { $link stream-read } " and " { $link read-quot } " generic words." } ;
--- /dev/null
+IN: ui.tools.interactor.tests
+USING: ui.tools.interactor ui.gadgets.panes namespaces
+ui.gadgets.editors concurrency.promises threads listener
+tools.test kernel calendar parser accessors calendar io ;
+
+\ <interactor> must-infer
+
+[
+ [ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+ [ ] [ "interactor" get register-self ] unit-test
+
+ [ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
+
+ [ ] [ <promise> "promise" set ] unit-test
+
+ [
+ self "interactor" get (>>thread)
+ "interactor" get stream-read-quot "promise" get fulfill
+ ] "Interactor test" spawn drop
+
+ ! This should not throw an exception
+ [ ] [ "interactor" get evaluate-input ] unit-test
+
+ [ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test
+
+ [ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test
+
+ [ ] [ "interactor" get evaluate-input ] unit-test
+
+ [ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
+] with-interactive-vocabs
+
+! Hang
+[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+[ ] [ [ "interactor" get stream-read-quot drop ] "A" spawn drop ] unit-test
+
+[ ] [ [ "interactor" get stream-read-quot drop ] "B" spawn drop ] unit-test
+
+[ ] [ 1000 sleep ] unit-test
+
+[ ] [ "interactor" get interactor-eof ] unit-test
+
+[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+: text "Hello world.\nThis is a test." ;
+
+[ ] [ text "interactor" get set-editor-string ] unit-test
+
+[ ] [ <promise> "promise" set ] unit-test
+
+[ ] [
+ [
+ "interactor" get register-self
+ "interactor" get contents "promise" get fulfill
+ ] in-thread
+] unit-test
+
+[ ] [ 100 sleep ] unit-test
+
+[ ] [ "interactor" get evaluate-input ] unit-test
+
+[ ] [ 100 sleep ] unit-test
+
+[ ] [ "interactor" get interactor-eof ] unit-test
+
+[ t ] [ "promise" get 2 seconds ?promise-timeout text = ] unit-test
+
+[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+[ ] [ text "interactor" get set-editor-string ] unit-test
+
+[ ] [ <promise> "promise" set ] unit-test
+
+[ ] [
+ [
+ "interactor" get register-self
+ "interactor" get stream-read1 "promise" get fulfill
+ ] in-thread
+] unit-test
+
+[ ] [ 100 sleep ] unit-test
+
+[ ] [ "interactor" get evaluate-input ] unit-test
+
+[ CHAR: H ] [ "promise" get 2 seconds ?promise-timeout ] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators continuations documents
+hashtables io io.styles kernel math math.order math.vectors
+models models.delay namespaces parser lexer prettyprint
+quotations sequences strings threads listener classes.tuple
+ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar
+ui.gadgets.presentations ui.gadgets.worlds ui.gestures
+definitions calendar concurrency.flags concurrency.mailboxes
+ui.tools.workspace accessors sets destructors ;
+IN: ui.tools.interactor
+
+! If waiting is t, we're waiting for user input, and invoking
+! evaluate-input resumes the thread.
+TUPLE: interactor < source-editor
+output history flag mailbox thread waiting help ;
+
+: register-self ( interactor -- )
+ <mailbox> >>mailbox
+ self >>thread
+ drop ;
+
+: interactor-continuation ( interactor -- continuation )
+ thread>> continuation>> value>> ;
+
+: interactor-busy? ( interactor -- ? )
+ #! We're busy if there's no thread to resume.
+ [ waiting>> ]
+ [ thread>> dup [ thread-registered? ] when ]
+ bi and not ;
+
+: interactor-use ( interactor -- seq )
+ dup interactor-busy? [ drop f ] [
+ use swap
+ interactor-continuation name>>
+ assoc-stack
+ ] if ;
+
+: <help-model> ( interactor -- model )
+ editor-caret 1/3 seconds <delay> ;
+
+: <interactor> ( output -- gadget )
+ interactor new-editor
+ V{ } clone >>history
+ <flag> >>flag
+ dup <help-model> >>help
+ swap >>output ;
+
+M: interactor graft*
+ [ call-next-method ] [ dup help>> add-connection ] bi ;
+
+M: interactor ungraft*
+ [ dup help>> remove-connection ] [ call-next-method ] bi ;
+
+: word-at-loc ( loc interactor -- word )
+ over [
+ [ gadget-model T{ one-word-elt } elt-string ] keep
+ interactor-use assoc-stack
+ ] [
+ 2drop f
+ ] if ;
+
+M: interactor model-changed
+ 2dup help>> eq? [
+ swap model-value over word-at-loc swap show-summary
+ ] [
+ call-next-method
+ ] if ;
+
+: write-input ( string input -- )
+ <input> presented associate
+ [ H{ { font-style bold } } format ] with-nesting ;
+
+: interactor-input. ( string interactor -- )
+ output>> [
+ dup string? [ dup write-input nl ] [ short. ] if
+ ] with-output-stream* ;
+
+: add-interactor-history ( str interactor -- )
+ over empty? [ 2drop ] [ interactor-history adjoin ] if ;
+
+: interactor-continue ( obj interactor -- )
+ mailbox>> mailbox-put ;
+
+: clear-input ( interactor -- ) gadget-model clear-doc ;
+
+: interactor-finish ( interactor -- )
+ #! The spawn is a kludge to make it infer. Stupid.
+ [ editor-string ] keep
+ [ interactor-input. ] 2keep
+ [ add-interactor-history ] keep
+ [ clear-input ] curry "Clearing input" spawn drop ;
+
+: interactor-eof ( interactor -- )
+ dup interactor-busy? [
+ f over interactor-continue
+ ] unless drop ;
+
+: evaluate-input ( interactor -- )
+ dup interactor-busy? [
+ dup control-value over interactor-continue
+ ] unless drop ;
+
+: interactor-yield ( interactor -- obj )
+ dup thread>> self eq? [
+ {
+ [ t >>waiting drop ]
+ [ flag>> raise-flag ]
+ [ mailbox>> mailbox-get ]
+ [ f >>waiting drop ]
+ } cleave
+ ] [ drop f ] if ;
+
+: interactor-read ( interactor -- lines )
+ [ interactor-yield ] [ interactor-finish ] bi ;
+
+M: interactor stream-readln
+ interactor-read dup [ first ] when ;
+
+: interactor-call ( quot interactor -- )
+ dup interactor-busy? [
+ 2dup interactor-input.
+ 2dup interactor-continue
+ ] unless 2drop ;
+
+M: interactor stream-read
+ swap dup zero? [
+ 2drop ""
+ ] [
+ >r interactor-read dup [ "\n" join ] when r> short head
+ ] if ;
+
+M: interactor stream-read-partial
+ stream-read ;
+
+M: interactor stream-read1
+ dup interactor-read {
+ { [ dup not ] [ 2drop f ] }
+ { [ dup empty? ] [ drop stream-read1 ] }
+ { [ dup first empty? ] [ 2drop CHAR: \n ] }
+ [ nip first first ]
+ } cond ;
+
+M: interactor dispose drop ;
+
+: go-to-error ( interactor error -- )
+ [ line>> 1- ] [ column>> ] bi 2array
+ over set-caret
+ mark>caret ;
+
+: handle-parse-error ( interactor error -- )
+ dup lexer-error? [ 2dup go-to-error error>> ] when
+ swap find-workspace debugger-popup ;
+
+: try-parse ( lines interactor -- quot/error/f )
+ [
+ drop parse-lines-interactive
+ ] [
+ 2nip
+ dup lexer-error? [
+ dup error>> unexpected-eof? [ drop f ] when
+ ] when
+ ] recover ;
+
+: handle-interactive ( lines interactor -- quot/f ? )
+ tuck try-parse {
+ { [ dup quotation? ] [ nip t ] }
+ { [ dup not ] [ drop "\n" swap user-input f f ] }
+ [ handle-parse-error f f ]
+ } cond ;
+
+M: interactor stream-read-quot
+ [ interactor-yield ] keep {
+ { [ over not ] [ drop ] }
+ { [ over callable? ] [ drop ] }
+ [
+ [ handle-interactive ] keep swap
+ [ interactor-finish ] [ nip stream-read-quot ] if
+ ]
+ } cond ;
+
+M: interactor pref-dim*
+ [ line-height 4 * 0 swap 2array ] [ call-next-method ] bi
+ vmax ;
+
+interactor "interactor" f {
+ { T{ key-down f f "RET" } evaluate-input }
+ { T{ key-down f { C+ } "k" } clear-input }
+} define-command-map
--- /dev/null
+Interactors are used to input Factor code
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: continuations documents ui.tools.interactor
+ui.tools.listener hashtables kernel namespaces parser sequences
+tools.test ui.commands ui.gadgets ui.gadgets.editors
+ui.gadgets.panes vocabs words tools.test.ui slots.private
+threads arrays generic threads accessors listener ;
+IN: ui.tools.listener.tests
+
+[ f ] [ "word" source-editor command-map commands>> empty? ] unit-test
+
+[ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test
+
+[ ] [ <listener-gadget> "listener" set ] unit-test
+
+"listener" get [
+ [ "dup" ] [
+ \ dup word-completion-string
+ ] unit-test
+
+ [ "equal?" ]
+ [ \ array \ equal? method word-completion-string ] unit-test
+
+ <pane> <interactor> "i" set
+
+ [ t ] [ "i" get interactor? ] unit-test
+
+ [ ] [ "SYMBOL:" "i" get set-editor-string ] unit-test
+
+ [ ] [
+ "i" get [ { "SYMBOL:" } parse-lines ] [ go-to-error ] recover
+ ] unit-test
+
+ [ t ] [
+ "i" get gadget-model doc-end
+ "i" get editor-caret* =
+ ] unit-test
+
+ ! Race condition discovered by SimonRC
+ [ ] [
+ [
+ "listener" get input>>
+ [ stream-read-quot drop ]
+ [ stream-read-quot drop ] bi
+ ] "OH, HAI" spawn drop
+ ] unit-test
+
+ [ ] [ "listener" get clear-output ] unit-test
+
+ [ ] [ "listener" get restart-listener ] unit-test
+
+ [ ] [ 1000 sleep ] unit-test
+
+ [ ] [ "listener" get com-end ] unit-test
+] with-grafted-gadget
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: inspector ui.tools.interactor ui.tools.inspector
+ui.tools.workspace help.markup io io.styles
+kernel models namespaces parser quotations sequences ui.commands
+ui.gadgets ui.gadgets.editors ui.gadgets.labelled
+ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
+ui.gadgets.tracks ui.gestures ui.operations vocabs words
+prettyprint listener debugger threads boxes concurrency.flags
+math arrays generic accessors combinators assocs ;
+IN: ui.tools.listener
+
+TUPLE: listener-gadget < track input output stack ;
+
+: listener-output, ( listener -- listener )
+ <scrolling-pane> >>output
+ dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
+
+: listener-streams ( listener -- input output )
+ [ input>> ] [ output>> <pane-stream> ] bi ;
+
+: <listener-input> ( listener -- gadget )
+ output>> <pane-stream> <interactor> ;
+
+: listener-input, ( listener -- listener )
+ dup <listener-input> >>input
+ dup input>>
+ { 0 100 } <limited-scroller>
+ "Input" <labelled-gadget>
+ f track-add ;
+
+: welcome. ( -- )
+ "If this is your first time with Factor, please read the " print
+ "handbook" ($link) "." print nl ;
+
+M: listener-gadget focusable-child*
+ input>> ;
+
+M: listener-gadget call-tool* ( input listener -- )
+ >r string>> r> input>> set-editor-string ;
+
+M: listener-gadget tool-scroller
+ output>> find-scroller ;
+
+: wait-for-listener ( listener -- )
+ #! Wait for the listener to start.
+ input>> flag>> wait-for-flag ;
+
+: workspace-busy? ( workspace -- ? )
+ listener>> input>> interactor-busy? ;
+
+: listener-input ( string -- )
+ get-workspace listener>> input>> set-editor-string ;
+
+: (call-listener) ( quot listener -- )
+ input>> interactor-call ;
+
+: call-listener ( quot -- )
+ [ workspace-busy? not ] get-workspace* listener>>
+ [ dup wait-for-listener (call-listener) ] 2curry
+ "Listener call" spawn drop ;
+
+M: listener-command invoke-command ( target command -- )
+ command-quot call-listener ;
+
+M: listener-operation invoke-command ( target command -- )
+ [ operation-hook call ] keep operation-quot call-listener ;
+
+: eval-listener ( string -- )
+ get-workspace
+ listener>> input>> [ set-editor-string ] keep
+ evaluate-input ;
+
+: listener-run-files ( seq -- )
+ dup empty? [
+ drop
+ ] [
+ [ [ run-file ] each ] curry call-listener
+ ] if ;
+
+: com-end ( listener -- )
+ input>> interactor-eof ;
+
+: clear-output ( listener -- )
+ output>> pane-clear ;
+
+\ clear-output H{ { +listener+ t } } define-command
+
+: clear-stack ( listener -- )
+ [ clear ] swap (call-listener) ;
+
+GENERIC: word-completion-string ( word -- string )
+
+M: word word-completion-string
+ name>> ;
+
+M: method-body word-completion-string
+ "method-generic" word-prop word-completion-string ;
+
+USE: generic.standard.engines.tuple
+
+M: engine-word word-completion-string
+ "engine-generic" word-prop word-completion-string ;
+
+: use-if-necessary ( word seq -- )
+ over vocabulary>> [
+ 2dup assoc-stack pick = [ 2drop ] [
+ >r vocabulary>> vocab-words r> push
+ ] if
+ ] [ 2drop ] if ;
+
+: insert-word ( word -- )
+ get-workspace workspace-listener input>>
+ [ >r word-completion-string r> user-input ]
+ [ interactor-use use-if-necessary ]
+ 2bi ;
+
+: quot-action ( interactor -- lines )
+ dup control-value
+ dup "\n" join pick add-interactor-history
+ swap select-all ;
+
+TUPLE: stack-display < track ;
+
+: <stack-display> ( workspace -- gadget )
+ listener>>
+ { 0 1 } stack-display new-track
+ over <toolbar> f track-add
+ swap
+ stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
+ 1 track-add ;
+
+M: stack-display tool-scroller
+ find-workspace workspace-listener tool-scroller ;
+
+: ui-listener-hook ( listener -- )
+ >r datastack r> listener-gadget-stack set-model ;
+
+: ui-error-hook ( error listener -- )
+ find-workspace debugger-popup ;
+
+: ui-inspector-hook ( obj listener -- )
+ find-workspace inspector-gadget
+ swap show-tool inspect-object ;
+
+: listener-thread ( listener -- )
+ dup listener-streams [
+ [ [ ui-listener-hook ] curry listener-hook set ]
+ [ [ ui-error-hook ] curry error-hook set ]
+ [ [ ui-inspector-hook ] curry inspector-hook set ] tri
+ welcome.
+ listener
+ ] with-streams* ;
+
+: start-listener-thread ( listener -- )
+ [
+ [ input>> register-self ] [ listener-thread ] bi
+ ] curry "Listener" spawn drop ;
+
+: restart-listener ( listener -- )
+ #! Returns when listener is ready to receive input.
+ {
+ [ com-end ]
+ [ clear-output ]
+ [ input>> clear-input ]
+ [ start-listener-thread ]
+ [ wait-for-listener ]
+ } cleave ;
+
+: init-listener ( listener -- )
+ f <model> swap set-listener-gadget-stack ;
+
+: <listener-gadget> ( -- gadget )
+ { 0 1 } listener-gadget new-track
+ dup init-listener
+ listener-output,
+ listener-input, ;
+
+: listener-help ( -- ) "ui-listener" help-window ;
+
+\ listener-help H{ { +nullary+ t } } define-command
+
+listener-gadget "toolbar" f {
+ { f restart-listener }
+ { T{ key-down f f "CLEAR" } clear-output }
+ { T{ key-down f { C+ } "CLEAR" } clear-stack }
+ { T{ key-down f { C+ } "d" } com-end }
+ { T{ key-down f f "F1" } listener-help }
+} define-command-map
+
+M: listener-gadget handle-gesture* ( gadget gesture delegate -- ? )
+ 3dup drop swap find-workspace workspace-page handle-gesture
+ [ default-gesture-handler ] [ 3drop f ] if ;
+
+M: listener-gadget graft*
+ [ call-next-method ] [ restart-listener ] bi ;
+
+M: listener-gadget ungraft*
+ [ com-end ] [ call-next-method ] bi ;
--- /dev/null
+Graphical code evaluator
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: continuations definitions ui.tools.browser
+ui.tools.interactor ui.tools.listener ui.tools.profiler
+ui.tools.search ui.tools.traceback ui.tools.workspace generic
+help.topics inference summary inspector io.files io.styles kernel
+namespaces parser prettyprint quotations tools.annotations
+editors tools.profiler tools.test tools.time tools.walker
+ui.commands ui.gadgets.editors ui.gestures ui.operations
+ui.tools.deploy vocabs vocabs.loader words sequences
+tools.vocabs classes compiler.units accessors ;
+IN: ui.tools.operations
+
+V{ } clone operations set-global
+
+! Objects
+[ drop t ] \ inspect H{
+ { +primary+ t }
+ { +listener+ t }
+} define-operation
+
+: com-prettyprint ( obj -- ) . ;
+
+[ drop t ] \ com-prettyprint H{
+ { +listener+ t }
+} define-operation
+
+: com-push ( obj -- obj ) ;
+
+[ drop t ] \ com-push H{
+ { +listener+ t }
+} define-operation
+
+: com-unparse ( obj -- ) unparse listener-input ;
+
+[ drop t ] \ com-unparse H{ } define-operation
+
+! Input
+
+: com-input ( obj -- ) string>> listener-input ;
+
+[ input? ] \ com-input H{
+ { +primary+ t }
+ { +secondary+ t }
+} define-operation
+
+! Restart
+[ restart? ] \ restart H{
+ { +primary+ t }
+ { +secondary+ t }
+ { +listener+ t }
+} define-operation
+
+! Continuation
+[ continuation? ] \ traceback-window H{
+ { +primary+ t }
+ { +secondary+ t }
+} define-operation
+
+! Pathnames
+: edit-file ( pathname -- ) edit ;
+
+[ pathname? ] \ edit-file H{
+ { +keyboard+ T{ key-down f { C+ } "E" } }
+ { +primary+ t }
+ { +secondary+ t }
+ { +listener+ t }
+} define-operation
+
+UNION: definition word method-spec link vocab vocab-link ;
+
+[ definition? ] \ edit H{
+ { +keyboard+ T{ key-down f { C+ } "E" } }
+ { +listener+ t }
+} define-operation
+
+: com-forget ( defspec -- )
+ [ forget ] with-compilation-unit ;
+
+[ definition? ] \ com-forget H{ } define-operation
+
+! Words
+[ word? ] \ insert-word H{
+ { +secondary+ t }
+} define-operation
+
+[ topic? ] \ com-follow H{
+ { +keyboard+ T{ key-down f { C+ } "H" } }
+ { +primary+ t }
+} define-operation
+
+: com-usage ( word -- )
+ get-workspace swap show-word-usage ;
+
+[ word? ] \ com-usage H{
+ { +keyboard+ T{ key-down f { C+ } "U" } }
+} define-operation
+
+[ word? ] \ fix H{
+ { +keyboard+ T{ key-down f { C+ } "F" } }
+ { +listener+ t }
+} define-operation
+
+[ word? ] \ watch H{ } define-operation
+
+[ word? ] \ breakpoint H{ } define-operation
+
+GENERIC: com-stack-effect ( obj -- )
+
+M: quotation com-stack-effect infer. ;
+
+M: word com-stack-effect def>> com-stack-effect ;
+
+[ word? ] \ com-stack-effect H{
+ { +listener+ t }
+} define-operation
+
+! Vocabularies
+: com-vocab-words ( vocab -- )
+ get-workspace swap show-vocab-words ;
+
+[ vocab? ] \ com-vocab-words H{
+ { +secondary+ t }
+ { +keyboard+ T{ key-down f { C+ } "B" } }
+} define-operation
+
+: com-enter-in ( vocab -- ) vocab-name set-in ;
+
+[ vocab? ] \ com-enter-in H{
+ { +keyboard+ T{ key-down f { C+ } "I" } }
+ { +listener+ t }
+} define-operation
+
+: com-use-vocab ( vocab -- ) vocab-name use+ ;
+
+[ vocab-spec? ] \ com-use-vocab H{
+ { +secondary+ t }
+ { +listener+ t }
+} define-operation
+
+[ vocab-spec? ] \ run H{
+ { +keyboard+ T{ key-down f { C+ } "R" } }
+ { +listener+ t }
+} define-operation
+
+[ vocab? ] \ test H{
+ { +keyboard+ T{ key-down f { C+ } "T" } }
+ { +listener+ t }
+} define-operation
+
+[ vocab-spec? ] \ deploy-tool H{ } define-operation
+
+! Quotations
+[ quotation? ] \ com-stack-effect H{
+ { +keyboard+ T{ key-down f { C+ } "i" } }
+ { +listener+ t }
+} define-operation
+
+[ quotation? ] \ walk H{
+ { +keyboard+ T{ key-down f { C+ } "w" } }
+ { +listener+ t }
+} define-operation
+
+[ quotation? ] \ time H{
+ { +keyboard+ T{ key-down f { C+ } "t" } }
+ { +listener+ t }
+} define-operation
+
+: com-show-profile ( workspace -- )
+ profiler-gadget call-tool ;
+
+: com-profile ( quot -- ) profile f com-show-profile ;
+
+[ quotation? ] \ com-profile H{
+ { +keyboard+ T{ key-down f { C+ } "r" } }
+ { +listener+ t }
+} define-operation
+
+! Profiler presentations
+[ dup usage-profile? swap vocab-profile? or ]
+\ com-show-profile H{ { +primary+ t } } define-operation
+
+! Operations -> commands
+source-editor
+"word"
+"These commands operate on the Factor word named by the token at the caret position."
+\ selected-word
+[ selected-word ]
+[ dup search [ ] [ no-word ] ?if ]
+define-operation-map
+
+interactor
+"quotation"
+"These commands operate on the entire contents of the input area."
+[ ]
+[ quot-action ]
+[ [ parse-lines ] with-compilation-unit ]
+define-operation-map
--- /dev/null
+Standard presentation operations
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ui.tools.workspace kernel quotations tools.profiler
+ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
+ui.gadgets.tracks ui.gestures ui.gadgets.buttons accessors ;
+IN: ui.tools.profiler
+
+TUPLE: profiler-gadget < track pane ;
+
+: <profiler-gadget> ( -- gadget )
+ { 0 1 } profiler-gadget new-track
+ dup <toolbar> f track-add
+ <pane> >>pane
+ dup pane>> <scroller> 1 track-add ;
+
+: with-profiler-pane ( gadget quot -- )
+ >r profiler-gadget-pane r> with-pane ;
+
+: com-full-profile ( gadget -- )
+ [ profile. ] with-profiler-pane ;
+
+: com-vocabs-profile ( gadget -- )
+ [ vocabs-profile. ] with-profiler-pane ;
+
+: com-method-profile ( gadget -- )
+ [ method-profile. ] with-profiler-pane ;
+
+: profiler-help ( -- ) "ui-profiler" help-window ;
+
+\ profiler-help H{ { +nullary+ t } } define-command
+
+profiler-gadget "toolbar" f {
+ { f com-full-profile }
+ { f com-vocabs-profile }
+ { f com-method-profile }
+ { T{ key-down f f "F1" } profiler-help }
+} define-command-map
+
+GENERIC: profiler-presentation ( obj -- quot )
+
+M: usage-profile profiler-presentation
+ usage-profile-word [ usage-profile. ] curry ;
+
+M: vocab-profile profiler-presentation
+ vocab-profile-vocab [ vocab-profile. ] curry ;
+
+M: f profiler-presentation
+ drop [ vocabs-profile. ] ;
+
+M: profiler-gadget call-tool* ( obj gadget -- )
+ swap profiler-presentation with-profiler-pane ;
--- /dev/null
+Graphical call profiler
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: assocs ui.tools.search help.topics io.files io.styles
+kernel namespaces sequences source-files threads
+tools.test ui.gadgets ui.gestures vocabs
+vocabs.loader words tools.test.ui debugger ;
+IN: ui.tools.search.tests
+
+[ f ] [
+ "no such word with this name exists, certainly"
+ f f <definition-search>
+ T{ key-down f { C+ } "x" } swap search-gesture
+] unit-test
+
+: assert-non-empty ( obj -- ) empty? f assert= ;
+
+: update-live-search ( search -- seq )
+ dup [
+ 300 sleep
+ live-search-list control-value
+ ] with-grafted-gadget ;
+
+: test-live-search ( gadget quot -- ? )
+ >r update-live-search dup assert-non-empty r> all? ;
+
+[ t ] [
+ "swp" all-words f <definition-search>
+ [ word? ] test-live-search
+] unit-test
+
+[ t ] [
+ "" all-words t <definition-search>
+ dup [
+ { "set-word-prop" } over live-search-field set-control-value
+ 300 sleep
+ search-value \ set-word-prop eq?
+ ] with-grafted-gadget
+] unit-test
+
+[ t ] [
+ "quot" <help-search>
+ [ link? ] test-live-search
+] unit-test
+
+[ t ] [
+ "factor" source-files get keys <source-file-search>
+ [ pathname? ] test-live-search
+] unit-test
+
+[ t ] [
+ "kern" <vocab-search>
+ [ vocab-spec? ] test-live-search
+] unit-test
+
+[ t ] [
+ "a" { "a" "b" "aa" } <history-search>
+ [ input? ] test-live-search
+] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs ui.tools.interactor ui.tools.listener
+ui.tools.workspace help help.topics io.files io.styles kernel
+models models.delay models.filter namespaces prettyprint
+quotations sequences sorting source-files definitions strings
+tools.completion tools.crossref classes.tuple ui.commands
+ui.gadgets ui.gadgets.editors ui.gadgets.lists
+ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations
+vocabs words vocabs.loader tools.vocabs unicode.case calendar ui
+;
+IN: ui.tools.search
+
+TUPLE: live-search < track field list ;
+
+: search-value ( live-search -- value )
+ live-search-list list-value ;
+
+: search-gesture ( gesture live-search -- operation/f )
+ search-value object-operations
+ [ operation-gesture = ] with find nip ;
+
+M: live-search handle-gesture* ( gadget gesture delegate -- ? )
+ drop over search-gesture dup [
+ over find-workspace hide-popup
+ >r search-value r> invoke-command f
+ ] [
+ 2drop t
+ ] if ;
+
+: find-live-search ( gadget -- search )
+ [ [ live-search? ] is? ] find-parent ;
+
+: find-search-list ( gadget -- list )
+ find-live-search live-search-list ;
+
+TUPLE: search-field < editor ;
+
+: <search-field> ( -- gadget )
+ search-field new-editor ;
+
+search-field H{
+ { T{ key-down f f "UP" } [ find-search-list select-previous ] }
+ { T{ key-down f f "DOWN" } [ find-search-list select-next ] }
+ { T{ key-down f f "PAGE_UP" } [ find-search-list list-page-up ] }
+ { T{ key-down f f "PAGE_DOWN" } [ find-search-list list-page-down ] }
+ { T{ key-down f f "RET" } [ find-search-list invoke-value-action ] }
+} set-gestures
+
+: <search-model> ( live-search producer -- live-search filter )
+ >r dup field>> model>> ! live-search model :: producer
+ ui-running? [ 1/5 seconds <delay> ] when
+ [ "\n" join ] r> append <filter> ;
+
+: <search-list> ( live-search seq limited? presenter -- live-search list )
+ >r
+ [ limited-completions ] [ completions ] ? curry
+ <search-model>
+ >r [ find-workspace hide-popup ] r> r>
+ swap <list> ;
+
+: <live-search> ( string seq limited? presenter -- gadget )
+ { 0 1 } live-search new-track
+ <search-field> >>field
+ dup field>> f track-add
+ -roll <search-list> >>list
+ dup list>> <scroller> 1 track-add
+
+ swap
+ over field>> set-editor-string
+ dup field>> end-of-document ;
+
+M: live-search focusable-child* live-search-field ;
+
+M: live-search pref-dim* drop { 400 200 } ;
+
+: current-word ( workspace -- string )
+ workspace-listener listener-gadget-input selected-word ;
+
+: definition-candidates ( words -- candidates )
+ [ dup synopsis >lower ] { } map>assoc sort-values ;
+
+: <definition-search> ( string words limited? -- gadget )
+ >r definition-candidates r> [ synopsis ] <live-search> ;
+
+: word-candidates ( words -- candidates )
+ [ dup name>> >lower ] { } map>assoc ;
+
+: <word-search> ( string words limited? -- gadget )
+ >r word-candidates r> [ synopsis ] <live-search> ;
+
+: com-words ( workspace -- )
+ dup current-word all-words t <word-search>
+ "Word search" show-titled-popup ;
+
+: show-vocab-words ( workspace vocab -- )
+ "" over words natural-sort f <word-search>
+ "Words in " rot vocab-name append show-titled-popup ;
+
+: show-word-usage ( workspace word -- )
+ "" over smart-usage f <definition-search>
+ "Words and methods using " rot name>> append
+ show-titled-popup ;
+
+: help-candidates ( seq -- candidates )
+ [ dup >link swap article-title >lower ] { } map>assoc
+ sort-values ;
+
+: <help-search> ( string -- gadget )
+ all-articles help-candidates
+ f [ article-title ] <live-search> ;
+
+: com-search ( workspace -- )
+ "" <help-search> "Help search" show-titled-popup ;
+
+: source-file-candidates ( seq -- candidates )
+ [ dup <pathname> swap >lower ] { } map>assoc ;
+
+: <source-file-search> ( string files -- gadget )
+ source-file-candidates
+ f [ pathname-string ] <live-search> ;
+
+: all-source-files ( -- seq )
+ source-files get keys natural-sort ;
+
+: com-sources ( workspace -- )
+ "" all-source-files <source-file-search>
+ "Source file search" show-titled-popup ;
+
+: show-vocab-files ( workspace vocab -- )
+ "" over vocab-files <source-file-search>
+ "Source files in " rot vocab-name append show-titled-popup ;
+
+: vocab-candidates ( -- candidates )
+ all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
+
+: <vocab-search> ( string -- gadget )
+ vocab-candidates f [ vocab-name ] <live-search> ;
+
+: com-vocabs ( workspace -- )
+ dup current-word <vocab-search>
+ "Vocabulary search" show-titled-popup ;
+
+: history-candidates ( seq -- candidates )
+ [ dup <input> swap >lower ] { } map>assoc ;
+
+: <history-search> ( string seq -- gadget )
+ history-candidates
+ f [ input-string ] <live-search> ;
+
+: listener-history ( listener -- seq )
+ listener-gadget-input interactor-history <reversed> ;
+
+: com-history ( workspace -- )
+ "" over workspace-listener listener-history <history-search>
+ "History search" show-titled-popup ;
+
+workspace "toolbar" f {
+ { T{ key-down f { C+ } "p" } com-history }
+ { T{ key-down f f "TAB" } com-words }
+ { T{ key-down f { C+ } "u" } com-vocabs }
+ { T{ key-down f { C+ } "e" } com-sources }
+ { T{ key-down f { C+ } "h" } com-search }
+} define-command-map
--- /dev/null
+Support for graphical completion popups
--- /dev/null
+Graphical developer tools
--- /dev/null
+USING: editors help.markup help.syntax summary inspector io
+io.styles listener parser prettyprint tools.profiler
+tools.walker ui.commands ui.gadgets.editors ui.gadgets.panes
+ui.gadgets.presentations ui.gadgets.slots ui.operations
+ui.tools.browser ui.tools.interactor ui.tools.inspector
+ui.tools.listener ui.tools.operations ui.tools.profiler
+ui.tools.walker ui.tools.workspace vocabs ;
+IN: ui.tools
+
+ARTICLE: "ui-presentations" "Presentations in the UI"
+"A " { $emphasis "presentation" } " is a graphical view of an object which is directly linked to the object in some way. The help article links you see in the documentation browser are presentations; and if you " { $link see } " a word in the UI listener, all words in the definition will themselves be presentations."
+$nl
+"When you move the mouse over a presentation, it is highlighted with a rectangular border and a short summary of the object being presented is shown in the status bar (the summary is produced using the " { $link summary } " word)."
+$nl
+"Clicking a presentation with the left mouse button invokes a default operation, which usually views the object in some way. For example, clicking a presentation of a word jumps to the word definition in the " { $link "ui-browser" } "."
+$nl
+"Clicking and holding the right mouse button on a presentation displays a popup menu listing available operations."
+$nl
+"Presentation gadgets can be constructed directly using the " { $link <presentation> } " word, and they can also be written to " { $link pane } " gadgets using the " { $link write-object } " word." ;
+
+ARTICLE: "ui-listener" "UI listener"
+"The graphical listener is based around the terminal listener (" { $link "listener" } ") and adds the following features:"
+{ $list
+ "Input history"
+ { "Completion (see " { $link "ui-completion" } ")" }
+ { "Clickable presentations (see " { $link "ui-presentations" } ")" }
+}
+{ $command-map listener-gadget "toolbar" }
+{ $command-map interactor "interactor" }
+{ $command-map source-editor "word" }
+{ $command-map interactor "quotation" }
+{ $heading "Editing commands" }
+"The text editing commands are standard; see " { $link "gadgets-editors" } "."
+{ $heading "Implementation" }
+"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } "), and an input area (instance of " { $link interactor } "), and a stack display kept up to date using a " { $link listener-hook } "." ;
+
+ARTICLE: "ui-inspector" "UI inspector"
+"The graphical inspector builds on the terminal inspector (see " { $link "inspector" } ") and provides in-place editing of slot values."
+$nl
+"To display an object in the UI inspector, use the " { $link inspect } " word from the UI listener, or right-click a presentation and choose " { $strong "Inspect" } " from the menu that appears."
+$nl
+"When the UI inspector is running, all of the terminal inspector words are available, such as " { $link &at } " and " { $link &put } ". Changing slot values using terminal inspector words automatically updates the UI inspector display."
+$nl
+"Slots can also be edited graphically. Clicking the ellipsis to the left of the slot's textual representation displays a slot editor gadget. A text representation of the object can be edited in the slot editor. The parser is used to turn the text representation back into an object. Keep in mind that some structure is lost in the conversion; see " { $link "prettyprint-limitations" } "."
+$nl
+"The slot editor's text editing commands are standard; see " { $link "gadgets-editors" } "."
+$nl
+"The slot editor has a toolbar containing various commands."
+{ $command-map slot-editor "toolbar" }
+{ $command-map inspector-gadget "multi-touch" }
+"The following commands are also available."
+{ $command-map source-editor "word" } ;
+
+ARTICLE: "ui-browser" "UI browser"
+"The browser is used to display Factor code, documentation, and vocabularies."
+{ $command-map browser-gadget "toolbar" }
+{ $command-map browser-gadget "multi-touch" }
+"Browsers are instances of " { $link browser-gadget } "." ;
+
+ARTICLE: "ui-profiler" "UI profiler"
+"The graphical profiler is based on the terminal profiler (see " { $link "profiling" } ") and adds more convenient browsing of profiler results."
+$nl
+"To use the profiler, enter a piece of code in the listener input area and press " { $operation com-profile } "."
+$nl
+"Vocabulary and word presentations in the profiler pane can be clicked on to show profiler results pertaining to the object in question. Clicking a vocabulary in the profiler yields the same output as the " { $link vocab-profile. } " word, and clicking a word yields the same output as the " { $link usage-profile. } " word. Consult " { $link "profiling" } " for details."
+{ $command-map profiler-gadget "toolbar" } ;
+
+ARTICLE: "ui-cocoa" "Functionality specific to Mac OS X"
+"On Mac OS X, the Factor UI offers additional features which integrate with this operating system."
+$nl
+"First, a standard Mac-style menu bar is provided, which offers the bare minimum of what you would expect from a Mac OS X application."
+$nl
+"Dropping a source file onto the Factor icon in the dock runs the source file in the listener."
+$nl
+"If you install " { $strong "Factor.app" } " in your " { $strong "Applications" } " folder, then other applications will be able to call Factor via the System Services feature. For example, you can select some text in " { $strong "TextEdit.app" } ", then invoke the " { $strong "TextEdit->Services->Factor->Evaluate Selection" } " menu item, which will replace the selected text with the result of evaluating it in Factor."
+
+;
+
+ARTICLE: "ui-tool-tutorial" "UI tool tutorial"
+"The following is an example of a typical session with the UI which should give you a taste of its power:"
+{ $list
+ { "You decide to refactor some code, and move a few words from a source file you have already loaded, into a new source file." }
+ { "You press " { $operation edit } " in the listener, which displays a gadget where you can type part of a loaded file's name, and then press " { $snippet "RET" } " when the correct completion is highlighted. This opens the file in your editor." }
+ { "You refactor your words, move them to a new source file, and load the new file using " { $link run-file } "." }
+ { "Interactively testing the new code reveals a problem with one particular code snippet, so you enter it in the listener's input area, and press " { $operation walk } " to invoke the single stepper." }
+ { "Single stepping through the code makes the problem obvious, so you right-click on a presentation of the broken word in the stepper, and choose " { $strong "Edit" } " from the menu." }
+ { "After fixing the problem in the source editor, you right click on the word in the stepper and invoke " { $strong "Reload" } " from the menu." }
+} ;
+
+ARTICLE: "ui-completion-words" "Word completion popup"
+"Clicking a word in the word completion popup displays the word definition in the " { $link "ui-browser" } ". Pressing " { $snippet "RET" } " with a word selected inserts the word name in the listener, along with a " { $link POSTPONE: USE: } " declaration (if necessary)."
+{ $operations \ $operations } ;
+
+ARTICLE: "ui-completion-vocabs" "Vocabulary completion popup"
+"Clicking a vocabulary in the vocabulary completion popup displays a list of words in the vocabulary in another " { $link "ui-completion-words" } ". Pressing " { $snippet "RET" } " adds the vocabulary to the current search path, just as if you invoked " { $link POSTPONE: USE: } "."
+{ $operations "kernel" vocab } ;
+
+ARTICLE: "ui-completion-sources" "Source file completion popup"
+"The source file completion popup lists all source files which have been previously loaded by " { $link run-file } ". Clicking a source file or pressing " { $snippet "RET" } " opens the source file in your editor with " { $link edit } "."
+{ $operations P" " } ;
+
+ARTICLE: "ui-completion" "UI completion popups"
+"Completion popups allow fast access to aspects of the environment. Completion popups can be invoked by clicking the row of buttons along the bottom of the workspace, or via keyboard commands:"
+{ $command-map workspace "toolbar" }
+"A completion popup instantly updates the list of completions as keys are typed. The list of completions can be navigated from the keyboard with the " { $snippet "UP" } " and " { $snippet "DOWN" } " arrow keys. Every completion has a " { $emphasis "primary action" } " and " { $emphasis "secondary action" } ". The primary action is invoked when clicking a completion, and the secondary action is invoked on the currently-selected completion when pressing " { $snippet "RET" } "."
+$nl
+"The primary and secondary actions, along with additional keyboard shortcuts, are documented for some completion popups in the below sections."
+{ $subsection "ui-completion-words" }
+{ $subsection "ui-completion-vocabs" }
+{ $subsection "ui-completion-sources" } ;
+
+ARTICLE: "ui-workspace-keys" "UI keyboard shortcuts"
+{ $command-map workspace "tool-switching" }
+{ $command-map workspace "scrolling" }
+{ $command-map workspace "workflow" }
+{ $command-map workspace "multi-touch" }
+{ $heading "Implementation" }
+"Workspaces are instances of " { $link workspace } "." ;
+
+ARTICLE: "ui-tools" "UI development tools"
+"The Factor development environment can seem rather different from what you are used to, because it is very simple and powerful.."
+$nl
+"To take full advantage of the UI, you should be using a supported text editor. See " { $link "editor" } "."
+{ $subsection "ui-tool-tutorial" }
+{ $subsection "ui-workspace-keys" }
+{ $subsection "ui-presentations" }
+{ $subsection "ui-completion" }
+{ $heading "Tools" }
+"A single-window " { $emphasis "workspace" } " contains the most frequently-used tools:"
+{ $subsection "ui-listener" }
+{ $subsection "ui-browser" }
+{ $subsection "ui-inspector" }
+{ $subsection "ui-profiler" }
+"Additional tools:"
+{ $subsection "ui-walker" }
+{ $subsection "ui.tools.deploy" }
+"Platform-specific features:"
+{ $subsection "ui-cocoa" } ;
+
+ABOUT: "ui-tools"
--- /dev/null
+USING: ui.tools ui.tools.interactor ui.tools.listener
+ui.tools.search ui.tools.workspace kernel models namespaces
+sequences tools.test ui.gadgets ui.gadgets.buttons
+ui.gadgets.labelled ui.gadgets.presentations
+ui.gadgets.scrollers vocabs tools.test.ui ui accessors ;
+IN: ui.tools.tests
+
+[ f ]
+[
+ <gadget> 0 <model> >>model <workspace-tabs> children>> empty?
+] unit-test
+
+[ ] [ <workspace> "w" set ] unit-test
+[ ] [ "w" get com-scroll-up ] unit-test
+[ ] [ "w" get com-scroll-down ] unit-test
+[ t ] [
+ "w" get workspace-book gadget-children
+ [ tool-scroller ] map sift [ scroller? ] all?
+] unit-test
+[ ] [ "w" get hide-popup ] unit-test
+[ ] [ <gadget> "w" get show-popup ] unit-test
+[ ] [ "w" get hide-popup ] unit-test
+
+[ ] [
+ <gadget> "w" get show-popup
+ <gadget> "w" get show-popup
+ "w" get hide-popup
+] unit-test
+
+[ ] [ <workspace> [ ] with-grafted-gadget ] unit-test
+
+"w" get [
+
+ [ ] [ "w" get "kernel" vocab show-vocab-words ] unit-test
+
+ [ ] [ notify-queued ] unit-test
+
+ [ ] [ "w" get workspace-popup closable-gadget-content
+ live-search-list gadget-child "p" set ] unit-test
+
+ [ t ] [ "p" get presentation? ] unit-test
+
+ [ ] [ "p" get <operations-menu> gadget-child gadget-child "c" set ] unit-test
+
+ [ ] [ notify-queued ] unit-test
+
+ [ t ] [ "c" get button? ] unit-test
+
+ [ ] [
+ "w" get workspace-listener listener-gadget-input
+ 3 handle-parse-error
+ ] unit-test
+
+ [ ] [ notify-queued ] unit-test
+] with-grafted-gadget
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs debugger ui.tools.workspace
+ui.tools.operations ui.tools.traceback ui.tools.browser
+ui.tools.inspector ui.tools.listener ui.tools.profiler
+ui.tools.operations inspector io kernel math models namespaces
+prettyprint quotations sequences ui ui.commands ui.gadgets
+ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
+ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
+ui.gadgets.presentations ui.gestures words vocabs.loader
+tools.test tools.vocabs ui.gadgets.buttons ui.gadgets.status-bar
+mirrors ;
+IN: ui.tools
+
+: <workspace-tabs> ( workspace -- tabs )
+ model>>
+ "tool-switching" workspace command-map commands>>
+ [ command-string ] { } assoc>map <enum> >alist
+ <toggle-buttons> ;
+
+: <workspace-book> ( workspace -- gadget )
+
+ dup
+ <stack-display>
+ <browser-gadget>
+ <inspector-gadget>
+ <profiler-gadget>
+ 4array
+
+ swap model>>
+
+ <book> ;
+
+: <workspace> ( -- workspace )
+ { 0 1 } workspace new-track
+
+ 0 <model> >>model
+ <listener-gadget> >>listener
+ dup <workspace-book> >>book
+
+ dup <workspace-tabs> f track-add
+ dup book>> 1/5 track-add
+ dup listener>> 4/5 track-add
+ dup <toolbar> f track-add ;
+
+: resize-workspace ( workspace -- )
+ dup track-sizes over control-value zero? [
+ 1/5 1 pick set-nth
+ 4/5 2 rot set-nth
+ ] [
+ 2/3 1 pick set-nth
+ 1/3 2 rot set-nth
+ ] if relayout ;
+
+M: workspace model-changed
+ nip
+ dup workspace-listener listener-gadget-output scroll>bottom
+ dup resize-workspace
+ request-focus ;
+
+[ workspace-window ] ui-hook set-global
+
+: com-listener ( workspace -- ) stack-display select-tool ;
+
+: com-browser ( workspace -- ) browser-gadget select-tool ;
+
+: com-inspector ( workspace -- ) inspector-gadget select-tool ;
+
+: com-profiler ( workspace -- ) profiler-gadget select-tool ;
+
+workspace "tool-switching" f {
+ { T{ key-down f { A+ } "1" } com-listener }
+ { T{ key-down f { A+ } "2" } com-browser }
+ { T{ key-down f { A+ } "3" } com-inspector }
+ { T{ key-down f { A+ } "4" } com-profiler }
+} define-command-map
+
+workspace "multi-touch" f {
+ { T{ zoom-out-action } com-listener }
+ { T{ up-action } refresh-all }
+} define-command-map
+
+\ workspace-window
+H{ { +nullary+ t } } define-command
+
+\ refresh-all
+H{ { +nullary+ t } { +listener+ t } } define-command
+
+workspace "workflow" f {
+ { T{ key-down f { C+ } "n" } workspace-window }
+ { T{ key-down f f "ESC" } hide-popup }
+ { T{ key-down f f "F2" } refresh-all }
+} define-command-map
+
+[
+ <workspace> dup "Factor workspace" open-status-window
+] workspace-window-hook set-global
+
+: inspect-continuation ( traceback -- )
+ control-value [ inspect ] curry call-listener ;
+
+traceback-gadget "toolbar" f {
+ { T{ key-down f f "v" } variables }
+ { T{ key-down f f "n" } inspect-continuation }
+} define-command-map
--- /dev/null
+Slava Pestov
--- /dev/null
+Traceback gadgets display a continuation in human-readable form
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors continuations kernel models namespaces
+ prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
+ ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
+ ui.gadgets.status-bar ui.gadgets.scrollers ui.gestures sequences
+ hashtables inspector ;
+
+IN: ui.tools.traceback
+
+: <callstack-display> ( model -- gadget )
+ [ [ continuation-call callstack. ] when* ]
+ t "Call stack" <labelled-pane> ;
+
+: <datastack-display> ( model -- gadget )
+ [ [ continuation-data stack. ] when* ]
+ t "Data stack" <labelled-pane> ;
+
+: <retainstack-display> ( model -- gadget )
+ [ [ continuation-retain stack. ] when* ]
+ t "Retain stack" <labelled-pane> ;
+
+TUPLE: traceback-gadget < track ;
+
+M: traceback-gadget pref-dim* drop { 550 600 } ;
+
+: <traceback-gadget> ( model -- gadget )
+ { 0 1 } traceback-gadget new-track
+ swap >>model
+
+ dup model>>
+ { 1 0 } <track>
+ over <datastack-display> 1/2 track-add
+ swap <retainstack-display> 1/2 track-add
+ 1/3 track-add
+
+ dup model>> <callstack-display> 2/3 track-add
+
+ dup <toolbar> f track-add ;
+
+: <namestack-display> ( model -- gadget )
+ [ [ continuation-name namestack. ] when* ]
+ <pane-control> ;
+
+: <variables-gadget> ( model -- gadget )
+ <namestack-display> { 400 400 } <limited-scroller> ;
+
+: variables ( traceback -- )
+ gadget-model <variables-gadget>
+ "Dynamic variables" open-status-window ;
+
+: traceback-window ( continuation -- )
+ <model> <traceback-gadget> "Traceback" open-window ;
--- /dev/null
+Slava Pestov
--- /dev/null
+Graphical code single stepper
--- /dev/null
+IN: ui.tools.walker\r
+USING: help.markup help.syntax ui.commands ui.operations\r
+ui.render tools.walker sequences ;\r
+\r
+ARTICLE: "ui-walker-step" "Stepping through code"\r
+"If the current position points to a word, the various stepping commands behave as follows:"\r
+{ $list\r
+ { { $link com-step } " executes the word and moves the current position one word further." }\r
+ { { $link com-into } " enters the word's definition, unless it is a primitive, in which case it behaves like " { $link com-step } "." }\r
+ { { $link com-out } " executes until the end of the current quotation." }\r
+}\r
+"If the current position points to a literal, the various stepping commands behave as follows:"\r
+{ $list\r
+ { { $link com-step } " pushes the literal on the data stack." }\r
+ { { $link com-into } " pushes the literal. If it is a quotation, a breakpoint is inserted at the beginning of the quotation, and if it is an array of quotations, a breakpoint is inserted at the beginning of each quotation element." }\r
+ { { $link com-out } " executes until the end of the current quotation." }\r
+}\r
+"The behavior of the " { $link com-into } " command is useful when debugging code using combinators. Instead of stepping into the definition of a combinator, which may be quite complex, you can set a breakpoint on the quotation and continue. For example, suppose the following quotation is being walked:"\r
+{ $code "{ 10 20 30 } [ 3 + . ] each" }\r
+"If the current position is on the quotation and " { $link com-into } " is invoked, the following quotation is pushed on the stack:"\r
+{ $code "[ break 3 + . ]" }\r
+"Invoking " { $link com-continue } " will continue execution until the breakpoint is hit, which in this case happens immediately. The stack can then be inspected to verify that the first element of the array, 10, was pushed. Invoking " { $link com-continue } " proceeds until the breakpoint is hit on the second iteration, at which time the top of the stack will contain the value 20. Invoking " { $link com-continue } " a third time will proceed on to the final iteration where 30 is at the top of the stack. Invoking " { $link com-continue } " again will end the walk of this code snippet, since no more iterations remain the quotation will never be called again and the breakpoint will not be hit."\r
+$nl\r
+"The " { $link com-back } " command travels backwards through time, and restore stacks. This does not undo side effects (modifying array entries, writing to files, formatting the hard drive, etc) and therefore can only be used reliably on referentially transparent code." ;\r
+\r
+ARTICLE: "breakpoints" "Setting breakpoints"\r
+"In addition to invoking the walker explicitly through the UI, it is possible to set breakpoints on words. See " { $link "tools.annotations" } "."\r
+$nl\r
+"Breakpoints can be inserted directly into code:"\r
+{ $subsection break }\r
+"Note that because the walker calls various core library and UI words while rendering its own user interface, setting a breakpoint on a word such as " { $link append } " or " { $link draw-gadget } " will hang the UI." ;\r
+\r
+ARTICLE: "ui-walker" "UI walker"\r
+"The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "."\r
+$nl\r
+"Walkers are instances of " { $link walker-gadget } "."\r
+{ $subsection "ui-walker-step" }\r
+{ $subsection "breakpoints" }\r
+{ $command-map walker-gadget "toolbar" } ;\r
+\r
+ABOUT: "ui-walker"\r
--- /dev/null
+USING: ui.tools.walker tools.test ;
+IN: ui.tools.walker.tests
+
+\ <walker-gadget> must-infer
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel concurrency.messaging inspector
+ui.tools.listener ui.tools.traceback ui.gadgets.buttons
+ui.gadgets.status-bar ui.gadgets.tracks ui.commands ui.gadgets
+models models.filter ui.tools.workspace ui.gestures
+ui.gadgets.labels ui threads namespaces tools.walker assocs
+combinators ;
+IN: ui.tools.walker
+
+TUPLE: walker-gadget < track
+status continuation thread
+traceback
+closing? ;
+
+: walker-command ( walker msg -- )
+ swap
+ dup thread>> thread-registered?
+ [ thread>> send-synchronous drop ]
+ [ 2drop ]
+ if ;
+
+: com-step ( walker -- ) step walker-command ;
+
+: com-into ( walker -- ) step-into walker-command ;
+
+: com-out ( walker -- ) step-out walker-command ;
+
+: com-back ( walker -- ) step-back walker-command ;
+
+: com-continue ( walker -- ) step-all walker-command ;
+
+: com-abandon ( walker -- ) abandon walker-command ;
+
+M: walker-gadget ungraft*
+ [ t >>closing? drop ] [ com-continue ] [ call-next-method ] tri ;
+
+M: walker-gadget focusable-child*
+ traceback>> ;
+
+: walker-state-string ( status thread -- string )
+ [
+ "Thread: " %
+ dup thread-name %
+ " (" %
+ swap {
+ { +stopped+ "Stopped" }
+ { +suspended+ "Suspended" }
+ { +running+ "Running" }
+ } at %
+ ")" %
+ drop
+ ] "" make ;
+
+: <thread-status> ( model thread -- gadget )
+ [ walker-state-string ] curry <filter> <label-control> ;
+
+: <walker-gadget> ( status continuation thread -- gadget )
+ { 0 1 } walker-gadget new-track
+ swap >>thread
+ swap >>continuation
+ swap >>status
+ dup continuation>> <traceback-gadget> >>traceback
+
+ dup <toolbar> f track-add
+ dup status>> self <thread-status> f track-add
+ dup traceback>> 1 track-add ;
+
+: walker-help ( -- ) "ui-walker" help-window ;
+
+\ walker-help H{ { +nullary+ t } } define-command
+
+walker-gadget "toolbar" f {
+ { T{ key-down f f "s" } com-step }
+ { T{ key-down f f "i" } com-into }
+ { T{ key-down f f "o" } com-out }
+ { T{ key-down f f "b" } com-back }
+ { T{ key-down f f "c" } com-continue }
+ { T{ key-down f f "a" } com-abandon }
+ { T{ key-down f f "d" } close-window }
+ { T{ key-down f f "F1" } walker-help }
+} define-command-map
+
+: walker-for-thread? ( thread gadget -- ? )
+ {
+ { [ dup walker-gadget? not ] [ 2drop f ] }
+ { [ dup walker-gadget-closing? ] [ 2drop f ] }
+ [ thread>> eq? ]
+ } cond ;
+
+: find-walker-window ( thread -- world/f )
+ [ swap walker-for-thread? ] curry find-window ;
+
+: walker-window ( status continuation thread -- )
+ [ <walker-gadget> ] [ thread-name ] bi open-status-window ;
+
+[
+ dup find-walker-window dup
+ [ raise-window 3drop ] [ drop [ walker-window ] with-ui ] if
+] show-walker-hook set-global
--- /dev/null
+Slava Pestov
--- /dev/null
+Graphical development environment
--- /dev/null
+IN: ui.tools.workspace.tests
+USING: tools.test ui.tools ;
+
+\ <workspace> must-infer
--- /dev/null
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes continuations help help.topics kernel models
+ sequences ui ui.backend ui.tools.debugger ui.gadgets
+ ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
+ ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
+ ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
+ ui.commands ui.gestures assocs arrays namespaces accessors ;
+
+IN: ui.tools.workspace
+
+TUPLE: workspace < track book listener popup ;
+
+: find-workspace ( gadget -- workspace ) [ workspace? ] find-parent ;
+
+SYMBOL: workspace-window-hook
+
+: workspace-window* ( -- workspace ) workspace-window-hook get call ;
+
+: workspace-window ( -- ) workspace-window* drop ;
+
+GENERIC: call-tool* ( arg tool -- )
+
+GENERIC: tool-scroller ( tool -- scroller )
+
+M: gadget tool-scroller drop f ;
+
+: find-tool ( class workspace -- index tool )
+ book>> children>> [ class eq? ] with find ;
+
+: show-tool ( class workspace -- tool )
+ [ find-tool swap ] keep workspace-book gadget-model
+ set-model ;
+
+: select-tool ( workspace class -- ) swap show-tool drop ;
+
+: get-workspace* ( quot -- workspace )
+ [ >r dup workspace? r> [ drop f ] if ] curry find-window
+ [ dup raise-window gadget-child ]
+ [ workspace-window* ] if* ; inline
+
+: get-workspace ( -- workspace ) [ drop t ] get-workspace* ;
+
+: call-tool ( arg class -- )
+ get-workspace show-tool call-tool* ;
+
+: get-tool ( class -- gadget )
+ get-workspace find-tool nip ;
+
+: help-window ( topic -- )
+ [
+ <pane> [ [ help ] with-pane ] keep
+ { 550 700 } <limited-scroller>
+ ] keep
+ article-title open-window ;
+
+: hide-popup ( workspace -- )
+ dup popup>> track-remove
+ f >>popup
+ request-focus ;
+
+: show-popup ( gadget workspace -- )
+ dup hide-popup
+ over >>popup
+ over f track-add drop
+ request-focus ;
+
+: show-titled-popup ( workspace gadget title -- )
+ [ find-workspace hide-popup ] <closable-gadget>
+ swap show-popup ;
+
+: debugger-popup ( error workspace -- )
+ swap dup compute-restarts
+ [ find-workspace hide-popup ] <debugger>
+ "Error" show-titled-popup ;
+
+SYMBOL: workspace-dim
+
+{ 600 700 } workspace-dim set-global
+
+M: workspace pref-dim* drop workspace-dim get ;
+
+M: workspace focusable-child*
+ dup workspace-popup [ ] [ workspace-listener ] ?if ;
+
+: workspace-page ( workspace -- gadget )
+ workspace-book current-page ;
+
+M: workspace tool-scroller ( workspace -- scroller )
+ workspace-page tool-scroller ;
+
+: com-scroll-up ( workspace -- )
+ tool-scroller [ scroll-up-page ] when* ;
+
+: com-scroll-down ( workspace -- )
+ tool-scroller [ scroll-down-page ] when* ;
+
+workspace "scrolling"
+"The current tool's scroll pane can be scrolled from the keyboard."
+{
+ { T{ key-down f { C+ } "PAGE_UP" } com-scroll-up }
+ { T{ key-down f { C+ } "PAGE_DOWN" } com-scroll-down }
+} define-command-map
--- /dev/null
+Slava Pestov
--- /dev/null
+Gadget tree traversal
--- /dev/null
+IN: ui.traverse.tests
+USING: ui.gadgets ui.gadgets.labels namespaces sequences kernel
+math arrays tools.test io ui.gadgets.panes ui.traverse
+definitions compiler.units ;
+
+M: array gadget-children ;
+
+GENERIC: (flatten-tree) ( node -- )
+
+M: node (flatten-tree)
+ node-children [ (flatten-tree) ] each ;
+
+M: object (flatten-tree) , ;
+
+: flatten-tree ( seq -- newseq )
+ [ [ (flatten-tree) ] each ] { } make ;
+
+: gadgets-in-range ( frompath topath gadget -- seq )
+ gadget-subtree flatten-tree ;
+
+[ { "a" "b" "c" "d" } ] [
+ { 0 } { } { "a" "b" "c" "d" } gadgets-in-range
+] unit-test
+
+[ { "a" "b" } ] [
+ { } { 1 } { "a" "b" "c" "d" } gadgets-in-range
+] unit-test
+
+[ { "a" } ] [
+ { 0 } { 0 } { "a" "b" "c" "d" } gadgets-in-range
+] unit-test
+
+[ { "a" "b" "c" } ] [
+ { 0 } { 2 } { "a" "b" "c" "d" } gadgets-in-range
+] unit-test
+
+[ { "a" "b" "c" "d" } ] [
+ { 0 } { 3 } { "a" "b" "c" "d" } gadgets-in-range
+] unit-test
+
+[ { "a" "b" "c" "d" } ] [
+ { 0 0 } { 0 3 } { { "a" "b" "c" "d" } } gadgets-in-range
+] unit-test
+
+[ { "b" "c" "d" "e" } ] [
+ { 0 1 } { 1 } { { "a" "b" "c" "d" } "e" } gadgets-in-range
+] unit-test
+
+[ { "b" "c" "d" "e" "f" } ] [
+ { 0 1 } { 1 1 } { { "a" "b" "c" "d" } { "e" "f" "g" } } gadgets-in-range
+] unit-test
+
+[ { "b" "c" "d" { "e" "f" "g" } "h" "i" } ] [
+ { 0 1 } { 2 1 } { { "a" "b" "c" "d" } { "e" "f" "g" } { "h" "i" } } gadgets-in-range
+] unit-test
+
+[ { "b" "c" "d" { "e" "f" "g" } "h" } ] [
+ { 0 1 } { 2 0 0 } { { "a" "b" "c" "d" } { "e" "f" "g" } { { "h" "i" } "j" } } gadgets-in-range
+] unit-test
+
+[ { "b" "c" "d" { "e" "f" "g" } "h" "i" } ] [
+ { 0 1 } { 2 0 1 } { { "a" "b" "c" "d" } { "e" "f" "g" } { { "h" "i" } "j" } } gadgets-in-range
+] unit-test
+
+[ { array gadget-children } forget ] with-compilation-unit
--- /dev/null
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces sequences kernel math arrays io ui.gadgets
+generic combinators ;
+IN: ui.traverse
+
+TUPLE: node value children ;
+
+: traverse-step ( path gadget -- path' gadget' )
+ >r unclip r> gadget-children ?nth ;
+
+: make-node ( quot -- ) { } make node boa , ; inline
+
+: traverse-to-path ( topath gadget -- )
+ dup not [
+ 2drop
+ ] [
+ over empty? [
+ nip ,
+ ] [
+ [
+ 2dup gadget-children swap first head-slice %
+ tuck traverse-step traverse-to-path
+ ] make-node
+ ] if
+ ] if ;
+
+: traverse-from-path ( frompath gadget -- )
+ dup not [
+ 2drop
+ ] [
+ over empty? [
+ nip ,
+ ] [
+ [
+ 2dup traverse-step traverse-from-path
+ tuck gadget-children swap first 1+ tail-slice %
+ ] make-node
+ ] if
+ ] if ;
+
+: traverse-pre ( frompath gadget -- )
+ traverse-step traverse-from-path ;
+
+: (traverse-middle) ( frompath topath gadget -- )
+ >r >r first 1+ r> first r> gadget-children <slice> % ;
+
+: traverse-post ( topath gadget -- )
+ traverse-step traverse-to-path ;
+
+: traverse-middle ( frompath topath gadget -- )
+ [
+ 3dup nip traverse-pre
+ 3dup (traverse-middle)
+ 2dup traverse-post
+ 2nip
+ ] make-node ;
+
+DEFER: (gadget-subtree)
+
+: traverse-child ( frompath topath gadget -- )
+ dup -roll [
+ >r >r rest-slice r> r> traverse-step (gadget-subtree)
+ ] make-node ;
+
+: (gadget-subtree) ( frompath topath gadget -- )
+ {
+ { [ dup not ] [ 3drop ] }
+ { [ pick empty? pick empty? and ] [ 2nip , ] }
+ { [ pick empty? ] [ rot drop traverse-to-path ] }
+ { [ over empty? ] [ nip traverse-from-path ] }
+ { [ pick first pick first = ] [ traverse-child ] }
+ [ traverse-middle ]
+ } cond ;
+
+: gadget-subtree ( frompath topath gadget -- seq )
+ [ (gadget-subtree) ] { } make ;
+
+M: node gadget-text*
+ dup node-children swap node-value gadget-seq-text ;
+
+: gadget-text-range ( frompath topath gadget -- str )
+ gadget-subtree gadget-text ;
+
+: gadget-at-path ( parent path -- gadget )
+ [ swap nth-gadget ] each ;
--- /dev/null
+USING: help.markup help.syntax strings quotations debugger
+io.styles namespaces ui.backend ui.gadgets ui.gadgets.worlds
+ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids math.geometry.rect ;
+IN: ui
+
+HELP: windows
+{ $var-description "Global variable holding an association list mapping native window handles to " { $link world } " instances." } ;
+
+{ windows open-window find-window } related-words
+
+HELP: open-window
+{ $values { "gadget" gadget } { "title" string } }
+{ $description "Opens a native window with the specified title." } ;
+
+HELP: set-fullscreen?
+{ $values { "?" "a boolean" } { "gadget" gadget } }
+{ $description "Sets and unsets fullscreen mode for the gadget's world." } ;
+
+HELP: fullscreen?
+{ $values { "gadget" gadget } { "?" "a boolean" } }
+{ $description "Queries the gadget's world to see if it is running in fullscreen mode." } ;
+
+{ fullscreen? set-fullscreen? } related-words
+
+HELP: find-window
+{ $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" "a " { $link world } " or " { $link f } } }
+{ $description "Finds a native window such that the gadget passed to " { $link open-window } " satisfies the quotation, outputting " { $link f } " if no such gadget could be found. The front-most native window is checked first." } ;
+
+HELP: register-window
+{ $values { "world" world } { "handle" "a baackend-specific handle" } }
+{ $description "Adds a window to the global " { $link windows } " variable." }
+{ $notes "This word should only be called by the UI backend. User code can open new windows with " { $link open-window } "." } ;
+
+HELP: unregister-window
+{ $values { "handle" "a baackend-specific handle" } }
+{ $description "Removes a window from the global " { $link windows } " variable." }
+{ $notes "This word should only be called only by the UI backend, and not user code." } ;
+
+HELP: ui
+{ $description "Starts the Factor UI." } ;
+
+HELP: start-ui
+{ $description "Called by the UI backend to initialize the platform-independent parts of UI. This word should be called after the backend is ready to start displaying new windows, and before the event loop starts." } ;
+
+HELP: (open-window)
+{ $values { "world" world } }
+{ $description "Opens a native window containing the given world. This grafts the world by calling " { $link graft } ". Each world can only be displayed in one top-level window at a time." }
+{ $notes "This word should not be called directly by user code. Instead, use " { $link open-window } "." } ;
+
+HELP: ui-try
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation. If it throws an error, opens a window with the error and restores the data stack." }
+{ $notes "This is essentially a graphical variant of " { $link try } "." } ;
+
+ARTICLE: "ui-glossary" "UI glossary"
+{ $table
+ { "color specifier"
+ { "an array of four elements, all numbers between 0 and 1:"
+ { $list
+ "red"
+ "green"
+ "blue"
+ "alpha - 0 is completely transparent, 1 is completely opaque"
+ }
+ }
+ }
+ { "dimension" "a pair of integers denoting pixel size on screen" }
+ { "font specifier"
+ { "an array of three elements:"
+ { $list
+ { "font family - one of " { $snippet "serif" } ", " { $snippet "sans-serif" } " or " { $snippet "monospace" } }
+ { "font style - one of " { $link plain } ", " { $link bold } ", " { $link italic } " or " { $link bold-italic } }
+ "font size in points"
+ }
+ }
+ }
+ { "gadget" { "a graphical element which responds to user input. Gadgets are tuples which (directly or indirectly) inherit from " { $link gadget } "." } }
+ { "label specifier" { "a string, " { $link f } " or a gadget. See " { $link "ui.gadgets.buttons" } } }
+ { "orientation specifier" { "one of " { $snippet "{ 0 1 }" } " or " { $snippet "{ 1 0 }" } ", with the former denoting vertical orientation and the latter denoting horizontal. Using a vector instead of symbolic constants allows these values to be directly useful in co-ordinate calculations" } }
+ { "point" "a pair of integers denoting a pixel location on screen" }
+} ;
+
+ARTICLE: "building-ui" "Building user interfaces"
+"A gadget is a graphical element which responds to user input. Gadgets are implemented as tuples which (directly or indirectly) inherit from " { $link gadget } ", which in turn inherits from " { $link rect } "."
+{ $subsection gadget }
+"Gadgets are arranged in a hierarchy, and all visible gadgets except for instances of " { $link world } " are contained in a parent gadget, stored in the " { $link gadget-parent } " slot."
+{ $subsection "ui-geometry" }
+{ $subsection "ui-layouts" }
+{ $subsection "gadgets" }
+{ $subsection "ui-windows" }
+{ $see-also "models" } ;
+
+ARTICLE: "gadgets" "Pre-made UI gadgets"
+{ $subsection "ui.gadgets.labels" }
+{ $subsection "gadgets-polygons" }
+{ $subsection "ui.gadgets.borders" }
+{ $subsection "ui.gadgets.labelled" }
+{ $subsection "ui.gadgets.buttons" }
+{ $subsection "ui.gadgets.sliders" }
+{ $subsection "ui.gadgets.scrollers" }
+{ $subsection "gadgets-editors" }
+{ $subsection "ui.gadgets.panes" }
+{ $subsection "ui.gadgets.presentations" }
+{ $subsection "ui.gadgets.lists" } ;
+
+ARTICLE: "ui-geometry" "Gadget geometry"
+"The " { $link gadget } " class inherits from the " { $link rect } " class, and thus all gadgets have a bounding box:"
+{ $subsection rect }
+"Rectangles can be taken apart:"
+{ $subsection rect-loc }
+{ $subsection rect-dim }
+{ $subsection rect-bounds }
+{ $subsection rect-extent }
+"New rectangles can be created:"
+{ $subsection <zero-rect> }
+{ $subsection <rect> }
+{ $subsection <extent-rect> }
+"More utility words for working with rectangles:"
+{ $subsection offset-rect }
+{ $subsection rect-intersect }
+{ $subsection intersects? }
+"A gadget's bounding box is always relative to its parent:"
+{ $subsection gadget-parent }
+"Word for converting from a child gadget's co-ordinate system to a parent's:"
+{ $subsection relative-loc }
+{ $subsection screen-loc }
+"Hit testing:"
+{ $subsection pick-up }
+{ $subsection children-on } ;
+
+ARTICLE: "ui-windows" "Top-level windows"
+"Opening a top-level window:"
+{ $subsection open-window }
+"Finding top-level windows:"
+{ $subsection find-window }
+"Top-level windows are stored in a global variable:"
+{ $subsection windows }
+"When a gadget is displayed in a top-level window, or added to a parent which is already showing in a top-level window, a generic word is called allowing the gadget to perform initialization tasks:"
+{ $subsection graft* }
+"When the gadget is removed from a parent shown in a top-level window, or when the top-level window is closed, a corresponding generic word is called to clean up:"
+{ $subsection ungraft* }
+"The root of the gadget hierarchy in a window is a special gadget which is rarely operated on directly, but it is helpful to know it exists:"
+{ $subsection world } ;
+
+ARTICLE: "ui-backend" "Developing UI backends"
+"None of the words documented in this section should be called directly by user code. They are only of interest when developing new UI backends."
+{ $subsection "ui-backend-init" }
+{ $subsection "ui-backend-windows" }
+"UI backends may implement the " { $link "clipboard-protocol" } "." ;
+
+ARTICLE: "ui-backend-init" "UI initialization and the event loop"
+"An UI backend is required to define a word to start the UI:"
+{ $subsection ui }
+"This word should contain backend initialization, together with some boilerplate:"
+{ $code
+ "IN: shells"
+ ""
+ ": ui"
+ " ... backend-specific initialization ..."
+ " start-ui"
+ " ... more backend-specific initialization ..."
+ " ... start event loop here ... ;"
+}
+"The above word must call the following:"
+{ $subsection start-ui }
+"The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down."
+$nl
+"The event loop must not block, since otherwise other Factor threads and I/O will not run. Instead, it should poll for pending events, then call " { $link ui-wait } "." ;
+
+ARTICLE: "ui-backend-windows" "UI backend window management"
+"The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:"
+{ $subsection open-world-window }
+"This word should create a native window, store some kind of handle in the " { $link world-handle } " slot, then call two words:"
+{ $subsection register-window }
+"The following words must also be implemented:"
+{ $subsection set-title }
+{ $subsection raise-window }
+"When a world needs to be redrawn, the UI will call a word automatically:"
+{ $subsection draw-world }
+"This word can also be called directly if the UI backend is notified by the window system that window contents have been invalidated. Before and after drawing, two words are called, which the UI backend must implement:"
+{ $subsection select-gl-context }
+{ $subsection flush-gl-context }
+"If the user clicks the window's close box, you must call the following word:"
+{ $subsection close-window } ;
+
+HELP: raise-window
+{ $values { "gadget" gadget } }
+{ $description "Makes the native window containing the given gadget the front-most window." } ;
+
+ARTICLE: "ui-layouts" "Gadget hierarchy and layouts"
+"A layout gadget is a gadget whose sole purpose is to contain other gadgets. Layout gadgets position and resize children according to a certain policy, taking the preferred size of the children into account. Gadget hierarchies are constructed by building up nested layouts."
+{ $subsection "ui-layout-basics" }
+{ $subsection "ui-layout-combinators" }
+"Common layout gadgets:"
+{ $subsection "ui-pack-layout" }
+{ $subsection "ui-track-layout" }
+{ $subsection "ui-grid-layout" }
+{ $subsection "ui-frame-layout" }
+{ $subsection "ui-book-layout" }
+"Advanced topics:"
+{ $subsection "ui-null-layout" }
+{ $subsection "ui-incremental-layout" }
+{ $subsection "ui-layout-impl" }
+{ $see-also "ui.gadgets.borders" } ;
+
+ARTICLE: "ui-layout-basics" "Layout basics"
+"Gadgets are arranged in a hierarchy, and all visible gadgets except for instances of " { $link world } " are contained in a parent gadget."
+$nl
+"Managing the gadget hierarchy:"
+{ $subsection add-gadget }
+{ $subsection unparent }
+{ $subsection add-gadgets }
+{ $subsection clear-gadget }
+"Working with gadget children:"
+{ $subsection gadget-children }
+{ $subsection gadget-child }
+{ $subsection nth-gadget }
+{ $subsection each-child }
+{ $subsection child? }
+"Working with gadget parents:"
+{ $subsection parents }
+{ $subsection each-parent }
+{ $subsection find-parent }
+"Adding children, removing children and performing certain other operations initiates relayout requests automatically. In other cases, relayout may have to be triggered explicitly. There is no harm from doing this several times in a row as consecutive relayout requests are coalesced."
+{ $subsection relayout }
+{ $subsection relayout-1 }
+"Gadgets implement a generic word to inform their parents of their preferred size:"
+{ $subsection pref-dim* }
+"To get a gadget's preferred size, do not call the above word, instead use " { $link pref-dim } ", which caches the result." ;
+
+ARTICLE: "ui-layout-combinators" "Creating layouts using combinators"
+"The " { $link make } " combinator provides a convenient way of constructing sequences by keeping the intermediate sequence off the stack until construction is done. The " { $link , } " and " { $link % } " words operate on this implicit sequence, reducing stack noise."
+$nl
+"Similar tools exist for constructing complex gadget hierarchies. Different words are used for different types of gadgets; see " { $link "ui-pack-layout" } ", " { $link "ui-track-layout" } " and " { $link "ui-frame-layout" } " for specifics. This section documents their common factors."
+;
+
+ARTICLE: "ui-null-layout" "Manual layouts"
+"When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually:"
+{ $subsection set-rect-loc } ;
+
+ARTICLE: "ui-layout-impl" "Implementing layout gadgets"
+"The relayout process proceeds top-down, with parents laying out their children, which in turn lay out their children. Custom layout policy is implemented by defining a method on a generic word:"
+{ $subsection layout* }
+"When a " { $link layout* } " method is called, the size and location of the gadget has already been determined by its parent, and the method's job is to lay out the gadget's children. Children can be positioned and resized with a pair of words:"
+{ $subsection set-rect-loc }
+"Some assorted utility words which are useful for implementing layout logic:"
+{ $subsection pref-dim }
+{ $subsection pref-dims }
+{ $subsection prefer }
+{ $subsection max-dim }
+{ $subsection dim-sum }
+{ $warning
+ "When implementing the " { $link layout* } " generic word for a gadget which inherits from another layout, the " { $link children-on } " word might have to be re-implemented as well."
+ $nl
+ "For example, suppose you want a " { $link grid } " layout which also displays a popup gadget on top. The implementation of " { $link children-on } " for the " { $link grid } " class determines which children of the grid are visible at one time, and this will never include your popup, so it will not be rendered, nor will it respond to gestures. The solution is to re-implement " { $link children-on } " on your class."
+} ;
+
+ARTICLE: "new-gadgets" "Implementing new gadgets"
+"One of the goals of the Factor UI is to minimize the need to implement new types of gadgets by offering a highly reusable, orthogonal set of building blocks. However, in some cases implementing a new type of gadget is necessary, for example when writing a graphical visualization."
+$nl
+"Bare gadgets can be constructed directly, which is useful if all you need is a custom appearance with no further behavior (see " { $link "ui-pen-protocol" } "):"
+{ $subsection <gadget> }
+"New gadgets are defined as subclasses of an existing gadget type, perhaps even " { $link gadget } " itself. A parametrized constructor should be used to construct subclasses:"
+{ $subsection new-gadget }
+"Further topics:"
+{ $subsection "ui-gestures" }
+{ $subsection "ui-paint" }
+{ $subsection "ui-control-impl" }
+{ $subsection "clipboard-protocol" }
+{ $see-also "ui-layout-impl" } ;
+
+ARTICLE: "ui" "UI framework"
+{ $subsection "ui-glossary" }
+{ $subsection "building-ui" }
+{ $subsection "new-gadgets" }
+{ $subsection "ui-backend" } ;
+
+ABOUT: "ui"
--- /dev/null
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs io kernel math models namespaces
+prettyprint dlists deques sequences threads sequences words
+debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
+ui.gestures ui.backend ui.render continuations init combinators
+hashtables concurrency.flags sets accessors ;
+IN: ui
+
+! Assoc mapping aliens to gadgets
+SYMBOL: windows
+
+SYMBOL: stop-after-last-window?
+
+: event-loop? ( -- ? )
+ {
+ { [ stop-after-last-window? get not ] [ t ] }
+ { [ graft-queue deque-empty? not ] [ t ] }
+ { [ windows get-global empty? not ] [ t ] }
+ [ f ]
+ } cond ;
+
+: event-loop ( -- ) [ event-loop? ] [ do-events ] [ ] while ;
+
+: window ( handle -- world ) windows get-global at ;
+
+: window-focus ( handle -- gadget ) window world-focus ;
+
+: register-window ( world handle -- )
+ #! Add the new window just below the topmost window. Why?
+ #! So that if the new window doesn't actually receive focus
+ #! (eg, we're using focus follows mouse and the mouse is not
+ #! in the new window when it appears) Factor doesn't get
+ #! confused and send workspace operations to the new window,
+ #! etc.
+ swap 2array windows get-global push
+ windows get-global dup length 1 >
+ [ [ length 1- dup 1- ] keep exchange ] [ drop ] if ;
+
+: unregister-window ( handle -- )
+ windows global [ [ first = not ] with filter ] change-at ;
+
+: raised-window ( world -- )
+ windows get-global
+ [ [ second eq? ] with find drop ] keep
+ [ nth ] [ delete-nth ] [ nip ] 2tri push ;
+
+: focus-gestures ( new old -- )
+ drop-prefix <reversed>
+ T{ lose-focus } swap each-gesture
+ T{ gain-focus } swap each-gesture ;
+
+: focus-world ( world -- )
+ t over set-world-focused?
+ dup raised-window
+ focus-path f focus-gestures ;
+
+: unfocus-world ( world -- )
+ f over set-world-focused?
+ focus-path f swap focus-gestures ;
+
+M: world graft*
+ dup (open-window)
+ dup world-title over set-title
+ request-focus ;
+
+: reset-world ( world -- )
+ #! This is used when a window is being closed, but also
+ #! when restoring saved worlds on image startup.
+ dup world-fonts clear-assoc
+ dup unfocus-world
+ f swap set-world-handle ;
+
+M: world ungraft*
+ dup free-fonts
+ dup hand-clicked close-global
+ dup hand-gadget close-global
+ dup world-handle (close-window)
+ reset-world ;
+
+: find-window ( quot -- world )
+ windows get values
+ [ gadget-child swap call ] with find-last nip ; inline
+
+SYMBOL: ui-hook
+
+: init-ui ( -- )
+ <dlist> \ graft-queue set-global
+ <dlist> \ layout-queue set-global
+ V{ } clone windows set-global ;
+
+: restore-gadget-later ( gadget -- )
+ dup gadget-graft-state {
+ { { f f } [ ] }
+ { { f t } [ ] }
+ { { t t } [
+ { f f } over set-gadget-graft-state
+ ] }
+ { { t f } [
+ dup unqueue-graft
+ { f f } over set-gadget-graft-state
+ ] }
+ } case graft-later ;
+
+: restore-gadget ( gadget -- )
+ dup restore-gadget-later
+ gadget-children [ restore-gadget ] each ;
+
+: restore-world ( world -- )
+ dup reset-world restore-gadget ;
+
+: restore-windows ( -- )
+ windows get [ values ] keep delete-all
+ [ restore-world ] each
+ forget-rollover ;
+
+: restore-windows? ( -- ? )
+ windows get empty? not ;
+
+: update-hand ( world -- )
+ dup hand-world get-global eq?
+ [ hand-loc get-global swap move-hand ] [ drop ] if ;
+
+: layout-queued ( -- seq )
+ [
+ in-layout? on
+ layout-queue [
+ dup layout find-world [ , ] when*
+ ] slurp-deque
+ ] { } make prune ;
+
+: redraw-worlds ( seq -- )
+ [ dup update-hand draw-world ] each ;
+
+: notify ( gadget -- )
+ dup gadget-graft-state
+ dup first { f f } { t t } ?
+ pick set-gadget-graft-state {
+ { { f t } [ dup activate-control graft* ] }
+ { { t f } [ dup deactivate-control ungraft* ] }
+ } case ;
+
+: notify-queued ( -- )
+ graft-queue [ notify ] slurp-deque ;
+
+: update-ui ( -- )
+ [ notify-queued layout-queued redraw-worlds ] assert-depth ;
+
+: ui-wait ( -- )
+ 10 sleep ;
+
+: ui-try ( quot -- ) [ ui-error ] recover ;
+
+SYMBOL: ui-thread
+
+: ui-running ( quot -- )
+ t \ ui-running set-global
+ [ f \ ui-running set-global ] [ ] cleanup ; inline
+
+: ui-running? ( -- ? )
+ \ ui-running get-global ;
+
+: update-ui-loop ( -- )
+ ui-running? ui-thread get-global self eq? and [
+ ui-notify-flag get lower-flag
+ [ update-ui ] ui-try
+ update-ui-loop
+ ] when ;
+
+: start-ui-thread ( -- )
+ [ self ui-thread set-global update-ui-loop ]
+ "UI update" spawn drop ;
+
+: open-world-window ( world -- )
+ dup pref-dim over (>>dim) dup relayout graft ;
+
+: open-window ( gadget title -- )
+ f <world> open-world-window ;
+
+: set-fullscreen? ( ? gadget -- )
+ find-world set-fullscreen* ;
+
+: fullscreen? ( gadget -- ? )
+ find-world fullscreen* ;
+
+: raise-window ( gadget -- )
+ find-world raise-window* ;
+
+HOOK: close-window ui-backend ( gadget -- )
+
+M: object close-window
+ find-world [ ungraft ] when* ;
+
+: start-ui ( -- )
+ restore-windows? [
+ restore-windows
+ ] [
+ init-ui ui-hook get call
+ ] if
+ notify-ui-thread start-ui-thread ;
+
+[
+ f \ ui-running set-global
+ <flag> ui-notify-flag set-global
+] "ui" add-init-hook
+
+HOOK: ui ui-backend ( -- )
+
+MAIN: ui
+
+: with-ui ( quot -- )
+ ui-running? [
+ call
+ ] [
+ f windows set-global
+ [
+ ui-hook set
+ stop-after-last-window? on
+ ui
+ ] with-scope
+ ] if ;
--- /dev/null
+Doug Coleman
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2005, 2006 Doug Coleman.
+! Portions copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings arrays assocs ui
+ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
+ui.gestures io kernel math math.vectors namespaces
+sequences strings vectors words windows.kernel32 windows.gdi32
+windows.user32 windows.opengl32 windows.messages windows.types
+windows.nt windows threads libc combinators continuations
+command-line shuffle opengl ui.render unicode.case ascii
+math.bitfields locals symbols accessors math.geometry.rect ;
+IN: ui.windows
+
+SINGLETON: windows-ui-backend
+
+: crlf>lf ( str -- str' )
+ CHAR: \r swap remove ;
+
+: lf>crlf ( str -- str' )
+ [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
+
+: enum-clipboard ( -- seq )
+ 0
+ [ EnumClipboardFormats win32-error dup dup 0 > ]
+ [ ]
+ [ drop ]
+ produce nip ;
+
+: with-clipboard ( quot -- )
+ f OpenClipboard win32-error=0/f
+ call
+ CloseClipboard win32-error=0/f ; inline
+
+: paste ( -- str )
+ [
+ CF_UNICODETEXT IsClipboardFormatAvailable zero? [
+ ! nothing to paste
+ ""
+ ] [
+ CF_UNICODETEXT GetClipboardData dup win32-error=0/f
+ dup GlobalLock dup win32-error=0/f
+ GlobalUnlock win32-error=0/f
+ utf16n alien>string
+ ] if
+ ] with-clipboard
+ crlf>lf ;
+
+: copy ( str -- )
+ lf>crlf [
+ utf16n string>alien
+ EmptyClipboard win32-error=0/f
+ GMEM_MOVEABLE over length 1+ GlobalAlloc
+ dup win32-error=0/f
+
+ dup GlobalLock dup win32-error=0/f
+ swapd byte-array>memory
+ dup GlobalUnlock win32-error=0/f
+ CF_UNICODETEXT swap SetClipboardData win32-error=0/f
+ ] with-clipboard ;
+
+TUPLE: pasteboard ;
+C: <pasteboard> pasteboard
+
+M: pasteboard clipboard-contents drop paste ;
+M: pasteboard set-clipboard-contents drop copy ;
+
+: init-clipboard ( -- )
+ <pasteboard> clipboard set-global
+ <clipboard> selection set-global ;
+
+! world-handle is a <win>
+TUPLE: win hWnd hDC hRC world title ;
+C: <win> win
+
+SYMBOLS: msg-obj class-name-ptr mouse-captured ;
+
+: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
+: ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
+
+: get-RECT-top-left ( RECT -- x y )
+ [ RECT-left ] keep RECT-top ;
+
+: get-RECT-dimensions ( RECT -- x y width height )
+ [ get-RECT-top-left ] keep
+ [ RECT-right ] keep [ RECT-left - ] keep
+ [ RECT-bottom ] keep RECT-top - ;
+
+: handle-wm-paint ( hWnd uMsg wParam lParam -- )
+ #! wParam and lParam are unused
+ #! only paint if width/height both > 0
+ 3drop window relayout-1 yield ;
+
+: handle-wm-size ( hWnd uMsg wParam lParam -- )
+ 2nip
+ [ lo-word ] keep hi-word 2array
+ dup { 0 0 } = [ 2drop ] [ swap window (>>dim) ] if ;
+
+: handle-wm-move ( hWnd uMsg wParam lParam -- )
+ 2nip
+ [ lo-word ] keep hi-word 2array
+ swap window (>>window-loc) ;
+
+: wm-keydown-codes ( -- key )
+ H{
+ { 8 "BACKSPACE" }
+ { 9 "TAB" }
+ { 13 "RET" }
+ { 27 "ESC" }
+ { 33 "PAGE_UP" }
+ { 34 "PAGE_DOWN" }
+ { 35 "END" }
+ { 36 "HOME" }
+ { 37 "LEFT" }
+ { 38 "UP" }
+ { 39 "RIGHT" }
+ { 40 "DOWN" }
+ { 45 "INSERT" }
+ { 46 "DELETE" }
+ { 112 "F1" }
+ { 113 "F2" }
+ { 114 "F3" }
+ { 115 "F4" }
+ { 116 "F5" }
+ { 117 "F6" }
+ { 118 "F7" }
+ { 119 "F8" }
+ { 120 "F9" }
+ { 121 "F10" }
+ { 122 "F11" }
+ { 123 "F12" }
+ } ;
+
+: key-state-down? ( key -- ? )
+ GetKeyState 16 bit? ;
+
+: left-shift? ( -- ? ) VK_LSHIFT key-state-down? ;
+: left-ctrl? ( -- ? ) VK_LCONTROL key-state-down? ;
+: left-alt? ( -- ? ) VK_LMENU key-state-down? ;
+: right-shift? ( -- ? ) VK_RSHIFT key-state-down? ;
+: right-ctrl? ( -- ? ) VK_RCONTROL key-state-down? ;
+: right-alt? ( -- ? ) VK_RMENU key-state-down? ;
+: shift? ( -- ? ) left-shift? right-shift? or ;
+: ctrl? ( -- ? ) left-ctrl? right-ctrl? or ;
+: alt? ( -- ? ) left-alt? right-alt? or ;
+: caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ;
+
+: switch-case ( seq -- seq )
+ dup first CHAR: a >= [ >upper ] [ >lower ] if ;
+
+: switch-case? ( -- ? ) shift? caps-lock? xor not ;
+
+: key-modifiers ( -- seq )
+ [
+ shift? [ S+ , ] when
+ ctrl? [ C+ , ] when
+ alt? [ A+ , ] when
+ ] { } make [ empty? not ] keep f ? ;
+
+: exclude-keys-wm-keydown
+ H{
+ { 16 "SHIFT" }
+ { 17 "CTRL" }
+ { 18 "ALT" }
+ { 20 "CAPS-LOCK" }
+ } ;
+
+: exclude-keys-wm-char
+ ! Values are ignored
+ H{
+ { 8 "BACKSPACE" }
+ { 9 "TAB" }
+ { 13 "RET" }
+ { 27 "ESC" }
+ } ;
+
+: exclude-key-wm-keydown? ( n -- bool )
+ exclude-keys-wm-keydown key? ;
+
+: exclude-key-wm-char? ( n -- bool )
+ exclude-keys-wm-char key? ;
+
+: keystroke>gesture ( n -- mods sym ? )
+ dup wm-keydown-codes at* [
+ nip >r key-modifiers r> t
+ ] [
+ drop 1string >r key-modifiers r>
+ C+ pick member? >r A+ pick member? r> or [
+ shift? [ >lower ] unless f
+ ] [
+ switch-case? [ switch-case ] when t
+ ] if
+ ] if ;
+
+:: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
+ wParam exclude-key-wm-keydown? [
+ wParam keystroke>gesture <key-down>
+ hWnd window-focus send-gesture drop
+ ] unless ;
+
+:: handle-wm-char ( hWnd uMsg wParam lParam -- )
+ wParam exclude-key-wm-char? ctrl? alt? xor or [
+ wParam 1string
+ hWnd window-focus user-input
+ ] unless ;
+
+:: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
+ wParam keystroke>gesture <key-up>
+ hWnd window-focus send-gesture drop ;
+
+:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
+ ? hwnd window set-world-active?
+ hwnd uMsg wParam lParam DefWindowProc ;
+
+: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
+ {
+ { [ over SC_MINIMIZE = ] [ f set-window-active ] }
+ { [ over SC_RESTORE = ] [ t set-window-active ] }
+ { [ over SC_MAXIMIZE = ] [ t set-window-active ] }
+ { [ dup alpha? ] [ 4drop 0 ] }
+ { [ t ] [ DefWindowProc ] }
+ } cond ;
+
+: cleanup-window ( handle -- )
+ dup win-title [ free ] when*
+ dup win-hRC wglDeleteContext win32-error=0/f
+ dup win-hWnd swap win-hDC ReleaseDC win32-error=0/f ;
+
+M: windows-ui-backend (close-window)
+ dup win-hWnd unregister-window
+ dup cleanup-window
+ win-hWnd DestroyWindow win32-error=0/f ;
+
+: handle-wm-close ( hWnd uMsg wParam lParam -- )
+ 3drop window ungraft ;
+
+: handle-wm-set-focus ( hWnd uMsg wParam lParam -- )
+ 3drop window [ focus-world ] when* ;
+
+: handle-wm-kill-focus ( hWnd uMsg wParam lParam -- )
+ 3drop window [ unfocus-world ] when* ;
+
+: message>button ( uMsg -- button down? )
+ {
+ { [ dup WM_LBUTTONDOWN = ] [ drop 1 t ] }
+ { [ dup WM_LBUTTONUP = ] [ drop 1 f ] }
+ { [ dup WM_MBUTTONDOWN = ] [ drop 2 t ] }
+ { [ dup WM_MBUTTONUP = ] [ drop 2 f ] }
+ { [ dup WM_RBUTTONDOWN = ] [ drop 3 t ] }
+ { [ dup WM_RBUTTONUP = ] [ drop 3 f ] }
+
+ { [ dup WM_NCLBUTTONDOWN = ] [ drop 1 t ] }
+ { [ dup WM_NCLBUTTONUP = ] [ drop 1 f ] }
+ { [ dup WM_NCMBUTTONDOWN = ] [ drop 2 t ] }
+ { [ dup WM_NCMBUTTONUP = ] [ drop 2 f ] }
+ { [ dup WM_NCRBUTTONDOWN = ] [ drop 3 t ] }
+ { [ dup WM_NCRBUTTONUP = ] [ drop 3 f ] }
+ } cond ;
+
+! If the user clicks in the window border ("non-client area")
+! Windows sends us an NC[LMR]BUTTONDOWN message; but if the
+! mouse is subsequently released outside the NC area, we receive
+! a [LMR]BUTTONUP message and Factor can get confused. So we
+! ignore BUTTONUP's that are a result of an NC*BUTTONDOWN.
+SYMBOL: nc-buttons
+
+: handle-wm-ncbutton ( hWnd uMsg wParam lParam -- )
+ 2drop nip
+ message>button nc-buttons get
+ swap [ push ] [ delete ] if ;
+
+: >lo-hi ( WORD -- array ) [ lo-word ] keep hi-word 2array ;
+: mouse-wheel ( lParam -- array ) >lo-hi [ sgn neg ] map ;
+
+: mouse-absolute>relative ( lparam handle -- array )
+ >r >lo-hi r>
+ "RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
+ get-RECT-top-left 2array v- ;
+
+: mouse-event>gesture ( uMsg -- button )
+ key-modifiers swap message>button
+ [ <button-down> ] [ <button-up> ] if ;
+
+: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
+ nip >r mouse-event>gesture r> >lo-hi rot window ;
+
+: set-capture ( hwnd -- )
+ mouse-captured get [
+ drop
+ ] [
+ [ SetCapture drop ] keep
+ mouse-captured set
+ ] if ;
+
+: release-capture ( -- )
+ ReleaseCapture win32-error=0/f
+ mouse-captured off ;
+
+: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
+ >r >r
+ over set-capture
+ dup message>button drop nc-buttons get delete
+ r> r> prepare-mouse send-button-down ;
+
+: handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
+ mouse-captured get [ release-capture ] when
+ pick message>button drop dup nc-buttons get member? [
+ nc-buttons get delete 4drop
+ ] [
+ drop prepare-mouse send-button-up
+ ] if ;
+
+: make-TRACKMOUSEEVENT ( hWnd -- alien )
+ "TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
+ "TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ;
+
+: handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
+ 2nip
+ over make-TRACKMOUSEEVENT
+ TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags
+ 0 over set-TRACKMOUSEEVENT-dwHoverTime
+ TrackMouseEvent drop
+ >lo-hi swap window move-hand fire-motion ;
+
+: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
+ >r nip r>
+ pick mouse-absolute>relative >r mouse-wheel r> rot window send-wheel ;
+
+: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
+ #! message sent if windows needs application to stop dragging
+ 4drop release-capture ;
+
+: handle-wm-mouseleave ( hWnd uMsg wParam lParam -- )
+ #! message sent if mouse leaves main application
+ 4drop forget-rollover ;
+
+SYMBOL: wm-handlers
+
+H{ } clone wm-handlers set-global
+
+: add-wm-handler ( quot wm -- )
+ dup array?
+ [ [ execute add-wm-handler ] with each ]
+ [ wm-handlers get-global set-at ] if ;
+
+[ handle-wm-close 0 ] WM_CLOSE add-wm-handler
+[ 4dup handle-wm-paint DefWindowProc ] WM_PAINT add-wm-handler
+
+[ handle-wm-size 0 ] WM_SIZE add-wm-handler
+[ handle-wm-move 0 ] WM_MOVE add-wm-handler
+
+[ 4dup handle-wm-keydown DefWindowProc ] { WM_KEYDOWN WM_SYSKEYDOWN } add-wm-handler
+[ 4dup handle-wm-char DefWindowProc ] { WM_CHAR WM_SYSCHAR } add-wm-handler
+[ 4dup handle-wm-keyup DefWindowProc ] { WM_KEYUP WM_SYSKEYUP } add-wm-handler
+
+[ handle-wm-syscommand ] WM_SYSCOMMAND add-wm-handler
+[ handle-wm-set-focus 0 ] WM_SETFOCUS add-wm-handler
+[ handle-wm-kill-focus 0 ] WM_KILLFOCUS add-wm-handler
+
+[ handle-wm-buttondown 0 ] WM_LBUTTONDOWN add-wm-handler
+[ handle-wm-buttondown 0 ] WM_MBUTTONDOWN add-wm-handler
+[ handle-wm-buttondown 0 ] WM_RBUTTONDOWN add-wm-handler
+[ handle-wm-buttonup 0 ] WM_LBUTTONUP add-wm-handler
+[ handle-wm-buttonup 0 ] WM_MBUTTONUP add-wm-handler
+[ handle-wm-buttonup 0 ] WM_RBUTTONUP add-wm-handler
+
+[ 4dup handle-wm-ncbutton DefWindowProc ]
+{ WM_NCLBUTTONDOWN WM_NCMBUTTONDOWN WM_NCRBUTTONDOWN
+WM_NCLBUTTONUP WM_NCMBUTTONUP WM_NCRBUTTONUP }
+add-wm-handler
+
+[ nc-buttons get-global delete-all DefWindowProc ]
+{ WM_EXITSIZEMOVE WM_EXITMENULOOP } add-wm-handler
+
+[ handle-wm-mousemove 0 ] WM_MOUSEMOVE add-wm-handler
+[ handle-wm-mousewheel 0 ] WM_MOUSEWHEEL add-wm-handler
+[ handle-wm-cancelmode 0 ] WM_CANCELMODE add-wm-handler
+[ handle-wm-mouseleave 0 ] WM_MOUSELEAVE add-wm-handler
+
+SYMBOL: trace-messages?
+
+! return 0 if you handle the message, else just let DefWindowProc return its val
+: ui-wndproc ( -- object )
+ "uint" { "void*" "uint" "long" "long" } "stdcall" [
+ [
+ pick
+ trace-messages? get-global [ dup windows-message-name name>> print flush ] when
+ wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
+ ] ui-try
+ ] alien-callback ;
+
+: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
+
+M: windows-ui-backend do-events
+ msg-obj get-global
+ dup peek-message? [ drop ui-wait ] [
+ [ TranslateMessage drop ]
+ [ DispatchMessage drop ] bi
+ ] if ;
+
+: register-wndclassex ( -- class )
+ "WNDCLASSEX" <c-object>
+ f GetModuleHandle
+ class-name-ptr get-global
+ pick GetClassInfoEx zero? [
+ "WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize
+ { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style
+ ui-wndproc over set-WNDCLASSEX-lpfnWndProc
+ 0 over set-WNDCLASSEX-cbClsExtra
+ 0 over set-WNDCLASSEX-cbWndExtra
+ f GetModuleHandle over set-WNDCLASSEX-hInstance
+ f GetModuleHandle "fraptor" utf16n string>alien LoadIcon
+ over set-WNDCLASSEX-hIcon
+ f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
+
+ class-name-ptr get-global over set-WNDCLASSEX-lpszClassName
+ RegisterClassEx dup win32-error=0/f
+ ] when ;
+
+: adjust-RECT ( RECT -- )
+ style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
+
+: make-RECT ( world -- RECT )
+ dup window-loc>> { 40 40 } vmax dup rot rect-dim v+
+ "RECT" <c-object>
+ over first over set-RECT-right
+ swap second over set-RECT-bottom
+ over first over set-RECT-left
+ swap second over set-RECT-top ;
+
+: make-adjusted-RECT ( rect -- RECT )
+ make-RECT dup adjust-RECT ;
+
+: create-window ( rect -- hwnd )
+ make-adjusted-RECT
+ >r class-name-ptr get-global f r>
+ >r >r >r ex-style r> r>
+ { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
+ r> get-RECT-dimensions
+ f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
+
+: show-window ( hWnd -- )
+ dup SW_SHOW ShowWindow drop ! always succeeds
+ dup SetForegroundWindow drop
+ SetFocus drop ;
+
+: init-win32-ui ( -- )
+ V{ } clone nc-buttons set-global
+ "MSG" malloc-object msg-obj set-global
+ "Factor-window" utf16n malloc-string class-name-ptr set-global
+ register-wndclassex drop
+ GetDoubleClickTime double-click-timeout set-global ;
+
+: cleanup-win32-ui ( -- )
+ class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
+ msg-obj get-global [ free ] when*
+ f class-name-ptr set-global
+ f msg-obj set-global ;
+
+: setup-pixel-format ( hdc -- )
+ 16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
+ swapd SetPixelFormat win32-error=0/f ;
+
+: get-dc ( hWnd -- hDC ) GetDC dup win32-error=0/f ;
+
+: get-rc ( hDC -- hRC )
+ dup wglCreateContext dup win32-error=0/f
+ [ wglMakeCurrent win32-error=0/f ] keep ;
+
+: setup-gl ( hwnd -- hDC hRC )
+ get-dc dup setup-pixel-format dup get-rc ;
+
+M: windows-ui-backend (open-window) ( world -- )
+ [ create-window dup setup-gl ] keep
+ [ f <win> ] keep
+ [ swap win-hWnd register-window ] 2keep
+ dupd set-world-handle
+ win-hWnd show-window ;
+
+M: windows-ui-backend select-gl-context ( handle -- )
+ [ win-hDC ] keep win-hRC wglMakeCurrent win32-error=0/f ;
+
+M: windows-ui-backend flush-gl-context ( handle -- )
+ win-hDC SwapBuffers win32-error=0/f ;
+
+! Move window to front
+M: windows-ui-backend raise-window* ( world -- )
+ world-handle [
+ win-hWnd SetFocus drop
+ ] when* ;
+
+M: windows-ui-backend set-title ( string world -- )
+ world-handle
+ dup win-title [ free ] when*
+ >r utf16n malloc-string r>
+ 2dup set-win-title
+ win-hWnd WM_SETTEXT 0 roll alien-address SendMessage drop ;
+
+M: windows-ui-backend ui
+ [
+ [
+ stop-after-last-window? on
+ init-clipboard
+ init-win32-ui
+ start-ui
+ event-loop
+ ] [ cleanup-win32-ui ] [ ] cleanup
+ ] ui-running ;
+
+M: windows-ui-backend beep ( -- )
+ 0 MessageBeep drop ;
+
+windows-ui-backend ui-backend set-global
+
+[ "ui" ] main-vocab-hook set-global
--- /dev/null
+Slava Pestov
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2005, 2008 Eduardo Cavazos and Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types arrays ui ui.gadgets
+ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render
+assocs kernel math namespaces opengl sequences strings x11.xlib
+x11.events x11.xim x11.glx x11.clipboard x11.constants
+x11.windows io.encodings.string io.encodings.ascii
+io.encodings.utf8 combinators debugger command-line qualified
+math.vectors classes.tuple opengl.gl threads math.geometry.rect ;
+QUALIFIED: system
+IN: ui.x11
+
+SINGLETON: x11-ui-backend
+
+: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
+
+TUPLE: x11-handle window glx xic ;
+
+C: <x11-handle> x11-handle
+
+M: world expose-event nip relayout ;
+
+M: world configure-event
+ over configured-loc over (>>window-loc)
+ swap configured-dim over (>>dim)
+ ! In case dimensions didn't change
+ relayout-1 ;
+
+: modifiers
+ {
+ { S+ HEX: 1 }
+ { C+ HEX: 4 }
+ { A+ HEX: 8 }
+ } ;
+
+: key-codes
+ H{
+ { HEX: FF08 "BACKSPACE" }
+ { HEX: FF09 "TAB" }
+ { HEX: FF0D "RET" }
+ { HEX: FF8D "ENTER" }
+ { HEX: FF1B "ESC" }
+ { HEX: FFFF "DELETE" }
+ { HEX: FF50 "HOME" }
+ { HEX: FF51 "LEFT" }
+ { HEX: FF52 "UP" }
+ { HEX: FF53 "RIGHT" }
+ { HEX: FF54 "DOWN" }
+ { HEX: FF55 "PAGE_UP" }
+ { HEX: FF56 "PAGE_DOWN" }
+ { HEX: FF57 "END" }
+ { HEX: FF58 "BEGIN" }
+ { HEX: FFBE "F1" }
+ { HEX: FFBF "F2" }
+ { HEX: FFC0 "F3" }
+ { HEX: FFC1 "F4" }
+ { HEX: FFC2 "F5" }
+ { HEX: FFC3 "F6" }
+ { HEX: FFC4 "F7" }
+ { HEX: FFC5 "F8" }
+ { HEX: FFC6 "F9" }
+ } ;
+
+: key-code ( keysym -- keycode action? )
+ dup key-codes at [ t ] [ 1string f ] ?if ;
+
+: event-modifiers ( event -- seq )
+ XKeyEvent-state modifiers modifier ;
+
+: key-down-event>gesture ( event world -- string gesture )
+ dupd
+ world-handle x11-handle-xic lookup-string
+ >r swap event-modifiers r> key-code <key-down> ;
+
+M: world key-down-event
+ [ key-down-event>gesture ] keep world-focus
+ [ send-gesture ] keep swap [ user-input ] [ 2drop ] if ;
+
+: key-up-event>gesture ( event -- gesture )
+ dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
+
+M: world key-up-event
+ >r key-up-event>gesture r> world-focus send-gesture drop ;
+
+: mouse-event>gesture ( event -- modifiers button loc )
+ dup event-modifiers over XButtonEvent-button
+ rot mouse-event-loc ;
+
+M: world button-down-event
+ >r mouse-event>gesture >r <button-down> r> r>
+ send-button-down ;
+
+M: world button-up-event
+ >r mouse-event>gesture >r <button-up> r> r>
+ send-button-up ;
+
+: mouse-event>scroll-direction ( event -- pair )
+ XButtonEvent-button {
+ { 4 { 0 -1 } }
+ { 5 { 0 1 } }
+ { 6 { -1 0 } }
+ { 7 { 1 0 } }
+ } at ;
+
+M: world wheel-event
+ >r dup mouse-event>scroll-direction swap mouse-event-loc r>
+ send-wheel ;
+
+M: world enter-event motion-event ;
+
+M: world leave-event 2drop forget-rollover ;
+
+M: world motion-event
+ >r dup XMotionEvent-x swap XMotionEvent-y 2array r>
+ move-hand fire-motion ;
+
+M: world focus-in-event
+ nip
+ dup world-handle x11-handle-xic XSetICFocus focus-world ;
+
+M: world focus-out-event
+ nip
+ dup world-handle x11-handle-xic XUnsetICFocus unfocus-world ;
+
+M: world selection-notify-event
+ [ world-handle x11-handle-window selection-from-event ] keep
+ world-focus user-input ;
+
+: supported-type? ( atom -- ? )
+ { "UTF8_STRING" "STRING" "TEXT" }
+ [ x-atom = ] with contains? ;
+
+: clipboard-for-atom ( atom -- clipboard )
+ {
+ { [ dup XA_PRIMARY = ] [ drop selection get ] }
+ { [ dup XA_CLIPBOARD = ] [ drop clipboard get ] }
+ [ drop <clipboard> ]
+ } cond ;
+
+: encode-clipboard ( string type -- bytes )
+ XSelectionRequestEvent-target
+ XA_UTF8_STRING = utf8 ascii ? encode ;
+
+: set-selection-prop ( evt -- )
+ dpy get swap
+ [ XSelectionRequestEvent-requestor ] keep
+ [ XSelectionRequestEvent-property ] keep
+ [ XSelectionRequestEvent-target ] keep
+ >r 8 PropModeReplace r>
+ [
+ XSelectionRequestEvent-selection
+ clipboard-for-atom x-clipboard-contents
+ ] keep encode-clipboard dup length XChangeProperty drop ;
+
+M: world selection-request-event
+ drop dup XSelectionRequestEvent-target {
+ { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
+ { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
+ { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
+ [ drop send-notify-failure ]
+ } cond ;
+
+M: x11-ui-backend (close-window) ( handle -- )
+ dup x11-handle-xic XDestroyIC
+ dup x11-handle-glx destroy-glx
+ x11-handle-window dup unregister-window
+ destroy-window ;
+
+M: world client-event
+ swap close-box? [ ungraft ] [ drop ] if ;
+
+: gadget-window ( world -- )
+ dup window-loc>> over rect-dim glx-window
+ over "Factor" create-xic <x11-handle>
+ 2dup x11-handle-window register-window
+ swap set-world-handle ;
+
+: wait-event ( -- event )
+ QueuedAfterFlush events-queued 0 > [
+ next-event dup
+ None XFilterEvent zero? [ drop wait-event ] unless
+ ] [
+ ui-wait wait-event
+ ] if ;
+
+M: x11-ui-backend do-events
+ wait-event dup XAnyEvent-window window dup
+ [ [ 2dup handle-event ] assert-depth ] when 2drop ;
+
+: x-clipboard@ ( gadget clipboard -- prop win )
+ x-clipboard-atom swap
+ find-world world-handle x11-handle-window ;
+
+M: x-clipboard copy-clipboard
+ [ x-clipboard@ own-selection ] keep
+ set-x-clipboard-contents ;
+
+M: x-clipboard paste-clipboard
+ >r find-world world-handle x11-handle-window
+ r> x-clipboard-atom convert-selection ;
+
+: init-clipboard ( -- )
+ XA_PRIMARY <x-clipboard> selection set-global
+ XA_CLIPBOARD <x-clipboard> clipboard set-global ;
+
+: set-title-old ( dpy window string -- )
+ dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
+
+: set-title-new ( dpy window string -- )
+ >r
+ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace
+ r> utf8 encode dup length XChangeProperty drop ;
+
+M: x11-ui-backend set-title ( string world -- )
+ world-handle x11-handle-window swap dpy get -rot
+ 3dup set-title-old set-title-new ;
+
+M: x11-ui-backend set-fullscreen* ( ? world -- )
+ world-handle x11-handle-window "XClientMessageEvent" <c-object>
+ tuck set-XClientMessageEvent-window
+ swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
+ over set-XClientMessageEvent-data0
+ ClientMessage over set-XClientMessageEvent-type
+ dpy get over set-XClientMessageEvent-display
+ "_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
+ 32 over set-XClientMessageEvent-format
+ "_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
+ >r dpy get root get 0 SubstructureNotifyMask r> XSendEvent drop ;
+
+
+M: x11-ui-backend (open-window) ( world -- )
+ dup gadget-window
+ world-handle x11-handle-window dup set-closable map-window ;
+
+M: x11-ui-backend raise-window* ( world -- )
+ world-handle [
+ dpy get swap x11-handle-window XRaiseWindow drop
+ ] when* ;
+
+M: x11-ui-backend select-gl-context ( handle -- )
+ dpy get swap
+ dup x11-handle-window swap x11-handle-glx glXMakeCurrent
+ [ "Failed to set current GLX context" throw ] unless ;
+
+M: x11-ui-backend flush-gl-context ( handle -- )
+ dpy get swap x11-handle-window glXSwapBuffers ;
+
+M: x11-ui-backend ui ( -- )
+ [
+ f [
+ [
+ stop-after-last-window? on
+ init-clipboard
+ start-ui
+ event-loop
+ ] with-xim
+ ] with-x
+ ] ui-running ;
+
+M: x11-ui-backend beep ( -- )
+ dpy get 100 XBell drop ;
+
+x11-ui-backend ui-backend set-global
+
+[ "DISPLAY" system:os-env "ui" "listener" ? ]
+main-vocab-hook set-global
: MAXPATHLEN 1024 ; inline
-: O_RDONLY HEX: 0000 ; inline
-: O_WRONLY HEX: 0001 ; inline
-: O_RDWR HEX: 0002 ; inline
-: O_APPEND HEX: 0008 ; inline
-: O_CREAT HEX: 0200 ; inline
-: O_TRUNC HEX: 0400 ; inline
-: O_EXCL HEX: 0800 ; inline
+: O_RDONLY HEX: 0000 ; inline
+: O_WRONLY HEX: 0001 ; inline
+: O_RDWR HEX: 0002 ; inline
+: O_NONBLOCK HEX: 0004 ; inline
+: O_APPEND HEX: 0008 ; inline
+: O_CREAT HEX: 0200 ; inline
+: O_TRUNC HEX: 0400 ; inline
+: O_EXCL HEX: 0800 ; inline
+: O_NOCTTY HEX: 20000 ; inline
+: O_NDELAY O_NONBLOCK ; inline
: SOL_SOCKET HEX: ffff ; inline
: SO_REUSEADDR HEX: 4 ; inline
: F_SETFD 2 ; inline
: F_SETFL 4 ; inline
: FD_CLOEXEC 1 ; inline
-: O_NONBLOCK 4 ; inline
C-STRUCT: sockaddr-in
{ "uchar" "len" }
: MAXPATHLEN 1024 ; inline
-: O_RDONLY HEX: 0000 ; inline
-: O_WRONLY HEX: 0001 ; inline
-: O_RDWR HEX: 0002 ; inline
-: O_CREAT HEX: 0040 ; inline
-: O_EXCL HEX: 0080 ; inline
-: O_TRUNC HEX: 0200 ; inline
-: O_APPEND HEX: 0400 ; inline
+: O_RDONLY HEX: 0000 ; inline
+: O_WRONLY HEX: 0001 ; inline
+: O_RDWR HEX: 0002 ; inline
+: O_CREAT HEX: 0040 ; inline
+: O_EXCL HEX: 0080 ; inline
+: O_NOCTTY HEX: 0100 ; inline
+: O_TRUNC HEX: 0200 ; inline
+: O_APPEND HEX: 0400 ; inline
+: O_NONBLOCK HEX: 0800 ; inline
+: O_NDELAY O_NONBLOCK ; inline
: SOL_SOCKET 1 ; inline
: FD_CLOEXEC 1 ; inline
: F_SETFL 4 ; inline
-: O_NONBLOCK HEX: 800 ; inline
C-STRUCT: addrinfo
{ "int" "flags" }
{ [ os bsd? ] [ "unix.bsd" require ] }
{ [ os solaris? ] [ "unix.solaris" require ] }
} cond
-
<string-reader> "forget-subclass-test" parse-stream
drop
] unit-test
+
+[ ] [
+ "IN: sequences TUPLE: reversed { seq read-only } ;" eval
+] unit-test
[ tuple-instance? ] 2curry define-predicate ;
: superclass-size ( class -- n )
- superclasses but-last-slice
- [ "slots" word-prop length ] sigma ;
+ superclasses but-last [ "slots" word-prop length ] sigma ;
: (instance-check-quot) ( class -- quot )
[
M: tuple-class update-class
{
+ [ define-boa-check ]
[ define-tuple-layout ]
[ define-tuple-slots ]
[ define-tuple-predicate ]
[ define-tuple-prototype ]
- [ define-boa-check ]
} cleave ;
: define-new-tuple-class ( class superclass slots -- )
] with each
] [
[ call-next-method ]
- [
- {
- "layout" "slots" "boa-check" "prototype"
- } reset-props
- ] bi
+ [ { "layout" "slots" "boa-check" "prototype" } reset-props ]
+ bi
] bi ;
M: tuple-class rank-class drop 0 ;
] [ drop f ] if ;
: dispatch-case ( value from to default array -- )
- >r >r 3dup between? [
- drop - >fixnum r> drop r> dispatch
+ >r >r 3dup between? r> r> rot [
+ >r 2drop - >fixnum r> dispatch
] [
- 2drop r> call r> drop
+ drop 2nip call
] if ; inline
: dispatch-case-quot ( default assoc -- quot )
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces sequences strings words assocs
-combinators accessors arrays ;
+USING: kernel math math.parser namespaces sequences strings
+words assocs combinators accessors arrays ;
IN: effects
TUPLE: effect in out terminated? ;
GENERIC: effect>string ( obj -- str )
M: string effect>string ;
M: word effect>string name>> ;
-M: integer effect>string drop "object" ;
+M: integer effect>string number>string ;
M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ;
: stack-picture ( seq -- string )
+ dup integer? [ "object" <repetition> ] when
[ [ effect>string % CHAR: \s , ] each ] "" make ;
M: effect effect>string ( effect -- string )
[ [ nip class<= ] curry assoc-filter ] 2bi ;
: convert-methods ( assoc class word -- assoc' )
- over >r >r split-methods dup assoc-empty? [
- r> r> 3drop
+ over [ split-methods ] 2dip pick assoc-empty? [
+ 3drop
] [
- r> execute r> pick set-at
+ [ execute ] dip pick set-at
] if ; inline
: (picker) ( n -- quot )
: (read) ( n quot -- n string )
over 0 <string> [
[
- >r call dup
- [ swap r> set-nth-unsafe f ] [ r> 3drop t ] if
+ slip over
+ [ swapd set-nth-unsafe f ] [ 3drop t ] if
] 2curry find-integer
] keep ; inline
: triple ( stream byte -- stream char )
BIN: 1111 bitand append-nums append-nums ; inline
-: quad ( stream byte -- stream char )
+: quadruple ( stream byte -- stream char )
BIN: 111 bitand append-nums append-nums append-nums ; inline
: begin-utf8 ( stream byte -- stream char )
{ [ dup -7 shift zero? ] [ ] }
{ [ dup -5 shift BIN: 110 number= ] [ double ] }
{ [ dup -4 shift BIN: 1110 number= ] [ triple ] }
- { [ dup -3 shift BIN: 11110 number= ] [ quad ] }
+ { [ dup -3 shift BIN: 11110 number= ] [ quadruple ] }
[ drop replacement-char ]
} cond ; inline
"The following two lines are equivalent:"
{ $code
"[ p ] [ q ] 2bi*"
- ">r >r q r> r> q"
+ ">r >r p r> r> q"
}
} ;
: integer, ( num radix -- )
dup 1 <= [ "Invalid radix" throw ] when
- dup >r /mod >digit , dup 0 >
- [ r> integer, ] [ r> 2drop ] if ;
+ [ /mod >digit , ] keep over 0 >
+ [ integer, ] [ 2drop ] if ;
PRIVATE>
: first ( seq -- first ) 0 swap nth ; inline
: second ( seq -- second ) 1 swap nth ; inline
: third ( seq -- third ) 2 swap nth ; inline
-: fourth ( seq -- fourth ) 3 swap nth ; inline
+: fourth ( seq -- fourth ) 3 swap nth ; inline
: set-first ( first seq -- ) 0 swap set-nth ; inline
: set-second ( second seq -- ) 1 swap set-nth ; inline
INSTANCE: reversed virtual-sequence
-: reverse ( seq -- newseq ) [ <reversed> ] [ like ] bi ;
-
! A slice of another sequence.
TUPLE: slice
{ from read-only }
pick >r >r (each) r> call r> finish-find ; inline
: (find-from) ( n seq quot quot' -- i elt )
- >r >r 2dup bounds-check? [
- r> r> (find)
- ] [
- r> r> 2drop 2drop f f
- ] if ; inline
+ [ 2dup bounds-check? ] 2dip
+ [ (find) ] 2curry
+ [ 2drop f f ]
+ if ; inline
: (monotonic) ( seq quot -- ? )
[ 2dup nth-unsafe rot 1+ rot nth-unsafe ]
tuck - 1- rot exchange-unsafe
] each 2drop ;
+: reverse ( seq -- newseq )
+ [
+ dup [ length ] keep new-sequence
+ [ 0 swap copy ] keep
+ [ reverse-here ] keep
+ ] keep like ;
+
: sum-lengths ( seq -- n )
0 [ length + ] reduce ;
] keep like ;
: padding ( seq n elt quot -- newseq )
- >r >r over length [-] dup zero?
- [ r> r> 3drop ] [ r> <repetition> r> call ] if ; inline
+ [
+ [ over length [-] dup zero? [ drop ] ] dip
+ [ <repetition> ] curry
+ ] dip compose if ; inline
: pad-left ( seq n elt -- padded )
[ swap dup (append) ] padding ;
[ left-trim ] [ right-trim ] bi ; inline
: sum ( seq -- n ) 0 [ + ] binary-reduce ;
+
: product ( seq -- n ) 1 [ * ] binary-reduce ;
: infimum ( seq -- n ) dup first [ min ] reduce ;
+
: supremum ( seq -- n ) dup first [ max ] reduce ;
: flip ( matrix -- newmatrix )
: sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline
: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
-
: dump ( from to seq accum -- )
#! 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 >r 2dup swap - r> r> pick 1 =
+ [ >r >r 2drop r> nth-unsafe r> push ] [
+ pick 2 = [
+ >r >r 2drop dup 1+
r> [ nth-unsafe ] curry bi@
r> [ push ] curry bi@
] [
- dup 3 = [
- 2drop dup 1+ dup 1+
+ pick 3 = [
+ >r >r 2drop dup 1+ dup 1+
r> [ nth-unsafe ] curry tri@
r> [ push ] curry tri@
] [
- drop r> subseq r> push-all
+ >r nip subseq r> push-all
] if
] if
] if ; inline
[ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline
: (sort-pairs) ( i1 i2 seq quot accum -- )
- >r >r 2dup length = [
- nip nth r> drop r> push
+ [ 2dup length = ] 2dip rot [
+ [ drop nip nth ] dip push
] [
- tuck [ nth-unsafe ] 2bi@ 2dup r> call +gt+ eq?
- [ swap ] when r> tuck [ push ] 2bi@
+ [
+ [ tuck [ nth-unsafe ] 2bi@ 2dup ] dip call +gt+ eq?
+ [ swap ] when
+ ] dip tuck [ push ] 2bi@
] if ; inline
: sort-pairs ( merge quot -- )
"just using the provided commands and the 4 numbers. The Following are the "
"provided commands: "
{ $link + } ", " { $link - } ", " { $link * } ", "
- { $link / } ", and " { $link swap } "."
+ { $link / } ", " { $link swap } ", and " { $link rot } "."
}
{ $examples
{ $example
"USE: 24-game"
- "24-able vector-24-able?"
+ "24-able vector-24-able? ."
"t"
}
{ $notes { $link 24-able? } " is used in " { $link 24-able } "." }
USING: kernel random namespaces shuffle sequences
parser io math prettyprint combinators continuations
-vectors words quotations accessors math.parser
-backtrack math.ranges locals fry memoize macros assocs ;
+arrays words quotations accessors math.parser backtrack assocs ;
IN: 24-game
-
+SYMBOL: commands
: nop ;
: do-something ( a b -- c ) { + - * } amb-execute ;
: maybe-swap ( a b -- a b ) { nop swap } amb-execute ;
: some-rots ( a b c -- a b c )
#! Try each permutation of 3 elements.
{ nop rot -rot swap spin swapd } amb-execute ;
-: makes-24? ( a b c d -- ? ) [ some-rots do-something some-rots do-something maybe-swap do-something 24 = ] [ 4drop ] if-amb ;
-: vector-24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ;
+: makes-24? ( a b c d -- ? )
+ [
+ 2 [ some-rots do-something ] times
+ maybe-swap do-something
+ 24 =
+ ]
+ [ 4drop ]
+ if-amb ;
: q ( -- obj ) "quit" ;
-: show-commands ( -- ) "Commands: " write "commands" get unparse print ;
+: show-commands ( -- ) "Commands: " write commands get unparse print ;
: report ( vector -- ) unparse print show-commands ;
: give-help ( -- ) "Command not found..." print show-commands ;
: find-word ( string choices -- word ) [ name>> = ] with find nip ;
-: obtain-word ( -- word ) readln "commands" get find-word dup [ drop give-help obtain-word ] unless ;
+: obtain-word ( -- word )
+ readln commands get find-word dup
+ [ drop give-help obtain-word ] unless ;
: done? ( vector -- t/f ) 1 swap length = ;
-: victory? ( vector -- t/f ) V{ 24 } = ;
-: apply-word ( vector word -- vector ) 1quotation with-datastack >vector ;
-: update-commands ( vector -- ) length 3 < [ "commands" [ \ rot swap remove ] change ] [ ] if ;
+: victory? ( vector -- t/f ) { 24 } = ;
+: apply-word ( vector word -- array ) 1quotation with-datastack >array ;
+: update-commands ( vector -- )
+ length 3 <
+ [ commands [ \ rot swap remove ] change ]
+ [ ]
+ if ;
DEFER: check-status
: quit-game ( vector -- ) drop "you're a quitter" print ;
: quit? ( vector -- t/f ) peek "quit" = ;
-: end-game ( vector -- ) dup victory? [ drop "You WON!" ] [ pop number>string " is not 24... You lose." append ] if print ;
-: repeat ( vector -- ) dup report obtain-word apply-word dup update-commands check-status ;
-: check-status ( object -- ) dup done? [ end-game ] [ dup quit? [ quit-game ] [ repeat ] if ] if ;
-: build-quad ( -- vector ) 4 [ 10 random ] replicate >vector ;
-: 24-able ( -- vector ) build-quad dup vector-24-able? [ drop build-quad ] unless ;
-: set-commands ( -- ) { + - * / rot swap q } "commands" set ;
-: play-game ( -- ) set-commands 24-able repeat ;
\ No newline at end of file
+: end-game ( vector -- )
+ dup victory?
+ [ drop "You WON!" ]
+ [ pop number>string " is not 24... You lose." append ]
+ if print ;
+
+! The following two words are mutually recursive,
+! providing the repl loop of the game
+: repeat ( vector -- )
+ dup report obtain-word apply-word dup update-commands check-status ;
+: check-status ( object -- )
+ dup done?
+ [ end-game ]
+ [ dup quit? [ quit-game ] [ repeat ] if ]
+ if ;
+: build-quad ( -- array ) 4 [ 10 random ] replicate >array ;
+: 24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ;
+: 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ;
+: set-commands ( -- ) { + - * / rot swap q } commands set ;
+: play-game ( -- ) set-commands 24-able repeat ;
+MAIN: play-game
\ No newline at end of file
demos
+games
\ No newline at end of file
USING: help.markup help.syntax ;
-IN: extra.animations
+IN: animations
HELP: animate ( quot duration -- )
+
{ $values
{ "quot" "a quot which uses " { $link progress } }
{ "duration" "a duration of time" }
}
-{ $description { $link animate } " calls " { $link reset-progress } " , then continously calls the given quot until the duration of time has elapsed. The quot should use " { $link progress } " at least once." }
-{ $example
- "USING: extra.animations calendar threads prettyprint ;"
- "[ 1 sleep progress unparse write \" ms elapsed\" print ] 1/20 seconds animate ;"
- "46 ms elapsed\n17 ms elapsed"
+{ $description
+ { $link animate } " calls " { $link reset-progress }
+ " , then continously calls the given quot until the"
+ " duration of time has elapsed. The quot should use "
+ { $link progress } " at least once."
+}
+{ $examples
+ { $unchecked-example
+ "USING: animations calendar threads prettyprint ;"
+ "[ 1 sleep progress unparse write \" ms elapsed\" print ] "
+ "1/20 seconds animate ;"
+ "46 ms elapsed\n17 ms elapsed"
+ }
+ { $notes "The amount of time elapsed between these iterations will very." }
} ;
HELP: reset-progress ( -- )
-{ $description "Initiates the timer. Call this before using a loop which makes use of " { $link progress } "." } ;
+{ $description
+ "Initiates the timer. Call this before using "
+ "a loop which makes use of " { $link progress } "."
+} ;
HELP: progress ( -- time )
{ $values { "time" "an integer" } }
-{ $description "Gives the time elapsed since the last time this word was called, in milliseconds." }
-{ $example
- "USING: extra.animations threads prettyprint ;"
- "reset-progress 3 [ 1 sleep progress unparse write \"ms elapsed\" print ] times ;"
- "31 ms elapsed\n18 ms elapsed\n16 ms elapsed"
+{ $description
+ "Gives the time elapsed since the last time"
+ " this word was called, in milliseconds."
+}
+{ $examples
+ { $unchecked-example
+ "USING: animations threads prettyprint ;"
+ "reset-progress 3 "
+ "[ 1 sleep progress unparse write \"ms elapsed\" print ] "
+ "times ;"
+ "31 ms elapsed\n18 ms elapsed\n16 ms elapsed"
+ }
+ { $notes "The amount of time elapsed between these iterations will very." }
} ;
-ARTICLE: "extra.animations" "Animations"
-"Provides a lightweight framework for properly simulating continuous functions of real time. This framework helps one create animations that use rates which do not change across platforms. The speed of the computer should correlate with the smoothness of the animation, not the speed of the animation!"
+ARTICLE: "animations" "Animations"
+"Provides a lightweight framework for properly simulating continuous"
+" functions of real time. This framework helps one create animations "
+"that use rates which do not change across platforms. The speed of the "
+"computer should correlate with the smoothness of the animation, not "
+"the speed of the animation!"
{ $subsection animate }
{ $subsection reset-progress }
{ $subsection progress }
-{ $link progress } " specifically provides the length of time since " { $link reset-progress } " was called, and also calls " { $link reset-progress } " as its last action. This can be directly used when one's quote runs for a specific number of iterations, instead of a length of time. If the animation is like most, and is expected to run for a specific length of time, " { $link animate } " should be used." ;
-ABOUT: "extra.animations"
\ No newline at end of file
+! A little talk about when to use progress and when to use animate
+ { $link progress } " specifically provides the length of time since "
+ { $link reset-progress } " was called, and also calls "
+ { $link reset-progress } " as its last action. This can be directly "
+ "used when one's quote runs for a specific number of iterations, instead "
+ "of a length of time. If the animation is like most, and is expected to "
+ "run for a specific length of time, " { $link animate } " should be used." ;
+ABOUT: "animations"
\ No newline at end of file
USING: kernel shuffle system locals
prettyprint math io namespaces threads calendar ;
-IN: extra.animations
+IN: animations
SYMBOL: last-loop
+SYMBOL: sleep-period
+
: reset-progress ( -- ) millis last-loop set ;
+! : my-progress ( -- progress ) millis
: progress ( -- progress ) millis last-loop get - reset-progress ;
+: progress-peek ( -- progress ) millis last-loop get - ;
: set-end ( duration -- end-time ) dt>milliseconds millis + ;
-: loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ;
-: animate ( quot duration -- ) reset-progress set-end loop ;
\ No newline at end of file
+: loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ; inline
+: animate ( quot duration -- ) reset-progress set-end loop ; inline
+: sample ( revs quot -- avg ) reset-progress dupd times progress swap / ; inline
\ No newline at end of file
-Reginald Keith Ford II
\ No newline at end of file
+Reginald Ford
\ No newline at end of file
+USING: kernel tools.test sequences vectors assocs.lib ;
IN: assocs.lib.tests
-USING: assocs.lib tools.test vectors ;
{ 1 1 } [ [ ?push ] histogram ] must-infer-as
+
+! substitute
+[ { 2 } ] [ { 1 } H{ { 1 2 } } [ ?at drop ] curry map ] unit-test
+[ { 3 } ] [ { 3 } H{ { 1 2 } } [ ?at drop ] curry map ] unit-test
+
+[ 2 ] [ 1 H{ { 1 2 } } [ ] [ ] if-at ] unit-test
+[ 3 ] [ 3 H{ { 1 2 } } [ ] [ ] if-at ] unit-test
+
+[ "hi" ] [ 1 H{ { 1 2 } } [ drop "hi" ] when-at ] unit-test
+[ 3 ] [ 3 H{ { 1 2 } } [ drop "hi" ] when-at ] unit-test
+[ 2 ] [ 1 H{ { 1 2 } } [ drop "hi" ] unless-at ] unit-test
+[ "hi" ] [ 3 H{ { 1 2 } } [ drop "hi" ] unless-at ] unit-test
+
H{ } clone [
swap [ change-at ] 2curry assoc-each
] keep ; inline
+
+: ?at ( obj assoc -- value/obj ? )
+ dupd at* [ [ nip ] [ drop ] if ] keep ;
+
+: if-at ( obj assoc quot1 quot2 -- )
+ [ ?at ] 2dip if ; inline
+
+: when-at ( obj assoc quot -- ) [ ] if-at ; inline
+
+: unless-at ( obj assoc quot -- ) [ ] swap if-at ; inline
tri* if\r
] with-scope ; inline\r
\r
+: cut-amb ( -- )\r
+ f failure set ;\r
: ligne ( -- )
{
- { 1 [ 4.5 y 1.15 0.8 size* -0.3 b line ] do }
+ { 1 [ 4.5 y 1.15 0.8 size* -0.3 b line ] }
{ 0.5 [ ] }
}
- call-random-weighted ;
+ rules ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: line ( -- ) [ insct ligne ] recursive ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: line ( -- ) { [ insct ligne ] } rule ;
: sole ( -- )
- [
- {
- {
- 1 [
- [ 1 brightness 0.5 saturation ligne ] do
- [ 140 r 1 hue sole ] do
- ]
- }
- { 0.01 [ ] }
- }
- call-random-weighted
- ]
- recursive ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ {
+ { 1 [ 1 brightness 0.5 saturation ligne ] [ 140 r 1 hue sole ] }
+ { 0.01 [ ] }
+ }
+ rules ;
-: centre ( -- )
- [ 1 b 5 s circle ] do
- [ sole ] do ;
+: centre ( -- ) { [ 1 b 5 s circle ] [ sole ] } rule ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2003, 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel combinators sequences arrays classes.tuple accessors colors.hsv ;
-
-IN: colors
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: color ;
-
-TUPLE: rgba < color red green blue alpha ;
-
-TUPLE: hsva < color hue saturation value alpha ;
-
-TUPLE: gray < color gray alpha ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: >rgba ( object -- rgba )
-
-M: rgba >rgba ( rgba -- rgba ) ;
-
-M: hsva >rgba ( hsva -- rgba )
- { [ hue>> ] [ saturation>> ] [ value>> ] [ alpha>> ] } cleave 4array
- [ hsv>rgb ] [ peek ] bi suffix first4 rgba boa ;
-
-M: gray >rgba ( gray -- rgba ) [ gray>> dup dup ] [ alpha>> ] bi rgba boa ;
-
-M: color red>> ( color -- red ) >rgba red>> ;
-M: color green>> ( color -- green ) >rgba green>> ;
-M: color blue>> ( color -- blue ) >rgba blue>> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: black T{ rgba f 0.0 0.0 0.0 1.0 } ;
-: blue T{ rgba f 0.0 0.0 1.0 1.0 } ;
-: cyan T{ rgba f 0 0.941 0.941 1 } ;
-: gray T{ rgba f 0.6 0.6 0.6 1.0 } ;
-: green T{ rgba f 0.0 1.0 0.0 1.0 } ;
-: light-gray T{ rgba f 0.95 0.95 0.95 0.95 } ;
-: light-purple T{ rgba f 0.8 0.8 1.0 1.0 } ;
-: magenta T{ rgba f 0.941 0 0.941 1 } ;
-: orange T{ rgba f 0.941 0.627 0 1 } ;
-: purple T{ rgba f 0.627 0 0.941 1 } ;
-: red T{ rgba f 1.0 0.0 0.0 1.0 } ;
-: white T{ rgba f 1.0 1.0 1.0 1.0 } ;
-: yellow T{ rgba f 1.0 1.0 0.0 1.0 } ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2007 Eduardo Cavazos
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel combinators arrays sequences math math.functions ;
-
-IN: colors.hsv
-
-<PRIVATE
-
-: H ( hsv -- H ) first ;
-
-: S ( hsv -- S ) second ;
-
-: V ( hsv -- V ) third ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: Hi ( hsv -- Hi ) H 60 / floor 6 mod ;
-
-: f ( hsv -- f ) [ H 60 / ] [ Hi ] bi - ;
-
-: p ( hsv -- p ) [ S 1 swap - ] [ V ] bi * ;
-
-: q ( hsv -- q ) [ [ f ] [ S ] bi * 1 swap - ] [ V ] bi * ;
-
-: t ( hsv -- t ) [ [ f 1 swap - ] [ S ] bi * 1 swap - ] [ V ] bi * ;
-
-PRIVATE>
-
-! h [0,360)
-! s [0,1]
-! v [0,1]
-
-: hsv>rgb ( hsv -- rgb )
-dup Hi
-{ { 0 [ [ V ] [ t ] [ p ] tri ] }
- { 1 [ [ q ] [ V ] [ p ] tri ] }
- { 2 [ [ p ] [ V ] [ t ] tri ] }
- { 3 [ [ p ] [ q ] [ V ] tri ] }
- { 4 [ [ t ] [ p ] [ V ] tri ] }
- { 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ;
"[ 20 random-prime ] [ 4 mod 3 = ] generate ."
"526367"
} ;
+
+HELP: %chance
+{ $values { "quot" quotation } { "n" integer } }
+{ $description "Calls the quotation " { $snippet "n" } " percent of the time." }
+{ $unchecked-example
+ "USING: io ;"
+ "[ \"hello, world! maybe.\" print ] 50 %chance"
+ ""
+} ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators fry namespaces quotations hashtables
sequences assocs arrays inference effects math math.ranges
-generalizations macros continuations locals ;
+generalizations macros continuations random locals ;
IN: combinators.lib
! Generalized versions of core combinators
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: quad ( x p q r s -- ) >r >r >r keep r> keep r> keep r> call ; inline
+
: 4slip ( quot a b c d -- a b c d ) 4 nslip ; inline
: 4keep ( w x y z quot -- w x y z ) 4 nkeep ; inline
[ drop ] rot compose attempt-all ; inline
: do-while ( pred body tail -- )
- >r tuck 2slip r> while ;
+ >r tuck 2slip r> while ; inline
: generate ( generator predicate -- obj )
[ dup ] swap [ dup [ nip ] unless not ] 3compose
dup [ 1quotation [ drop ] prepend ] map
>r [ [ dup ] prepend ] map r> zip [ drop f ] suffix
[ cond ] curry ;
+
+: %chance ( quot integer -- ) 100 random > swap when ; inline
: trim-text ( vector -- vector' )
[
dup name>> text = [
- [ text>> [ blank? ] trim ] keep
- [ set-tag-text ] keep
+ [ [ blank? ] trim ] change-text
] when
] map ;
: href-contains? ( str tag -- ? )
attributes>> "href" swap at* [ subseq? ] [ 2drop f ] if ;
+: find-hrefs ( vector -- vector' )
+ find-links
+ [ [
+ [ name>> "a" = ]
+ [ attributes>> "href" swap key? ] bi and ] filter
+ ] map sift [ [ attributes>> "href" swap at ] map ] map concat ;
: find-forms ( vector -- vector' )
"form" over find-opening-tags-by-name
[
{
{ [ dup name>> "form" = ]
- [ "form action: " write attributes>> "action" swap at print
- ] }
+ [ "form action: " write attributes>> "action" swap at print ] }
{ [ dup name>> "input" = ] [ input. ] }
[ drop ]
} cond
IN: html.parser.tests
[
- V{ T{ tag f "html" H{ } f f f } }
+ V{ T{ tag f "html" H{ } f f } }
] [ "<html>" parse-html ] unit-test
[
- V{ T{ tag f "html" H{ } f f t } }
+ V{ T{ tag f "html" H{ } f t } }
] [ "</html>" parse-html ] unit-test
[
- V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f f } }
+ V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f } }
] [ "<a href=\"http://factorcode.org/\">" parse-html ] unit-test
[
- V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f f } }
+ V{ T{ tag f "a" H{ { "href" "http://factorcode.org/" } } f f } }
] [ "<a href = \"http://factorcode.org/\" >" parse-html ] unit-test
[
H{ { "baz" "\"quux\"" } { "foo" "bar's" } }
f
f
- f
}
}
] [ "<a foo=\"bar's\" baz='\"quux\"' >" parse-html ] unit-test
{ "foo" "bar" }
{ "href" "http://factorcode.org/" }
{ "baz" "quux" }
- } f f f }
+ } f f }
}
] [ "<a href = \"http://factorcode.org/\" foo = bar baz='quux'a=pirsqd >" parse-html ] unit-test
[
V{
- T{ tag f "html" H{ } f f f }
- T{ tag f "head" H{ } f f f }
- T{ tag f "head" H{ } f f t }
- T{ tag f "html" H{ } f f t }
+ T{ tag f "html" H{ } f f }
+ T{ tag f "head" H{ } f f }
+ T{ tag f "head" H{ } f t }
+ T{ tag f "html" H{ } f t }
}
] [ "<html<head</head</html" parse-html ] unit-test
[
V{
- T{ tag f "head" H{ } f f f }
- T{ tag f "title" H{ } f f f }
- T{ tag f text f "Spagna" f f }
- T{ tag f "title" H{ } f f t }
- T{ tag f "head" H{ } f f t }
+ T{ tag f "head" H{ } f f }
+ T{ tag f "title" H{ } f f }
+ T{ tag f text f "Spagna" f }
+ T{ tag f "title" H{ } f t }
+ T{ tag f "head" H{ } f t }
}
] [ "<head<title>Spagna</title></head" parse-html ] unit-test
-USING: arrays html.parser.utils hashtables io kernel
+USING: accessors arrays html.parser.utils hashtables io kernel
namespaces prettyprint quotations
-sequences splitting state-parser strings unicode.categories unicode.case ;
+sequences splitting state-parser strings unicode.categories unicode.case
+sequences.lib ;
IN: html.parser
-TUPLE: tag name attributes text matched? closing? ;
+TUPLE: tag name attributes text closing? ;
-SYMBOL: text
-SYMBOL: dtd
-SYMBOL: comment
-SYMBOL: javascript
+SINGLETON: text
+SINGLETON: dtd
+SINGLETON: comment
SYMBOL: tagstack
: push-tag ( tag -- )
tagstack get push ;
: closing-tag? ( string -- ? )
- dup empty? [
- drop f
- ] [
- dup first CHAR: / =
- swap peek CHAR: / = or
- ] if ;
+ [ f ]
+ [ [ first ] [ peek ] bi [ CHAR: / = ] bi@ or ] if-empty ;
: <tag> ( name attributes closing? -- tag )
- { set-tag-name set-tag-attributes set-tag-closing? }
- tag construct ;
+ tag new
+ swap >>closing?
+ swap >>attributes
+ swap >>name ;
-: make-tag ( str attribs -- tag )
+: make-tag ( string attribs -- tag )
>r [ closing-tag? ] keep "/" trim1 r> rot <tag> ;
-: make-text-tag ( str -- tag )
- T{ tag f text } clone [ set-tag-text ] keep ;
+: make-text-tag ( string -- tag )
+ tag new
+ text >>name
+ swap >>text ;
-: make-comment-tag ( str -- tag )
- T{ tag f comment } clone [ set-tag-text ] keep ;
+: make-comment-tag ( string -- tag )
+ tag new
+ comment >>name
+ swap >>text ;
-: make-dtd-tag ( str -- tag )
- T{ tag f dtd } clone [ set-tag-text ] keep ;
+: make-dtd-tag ( string -- tag )
+ tag new
+ dtd >>name
+ swap >>text ;
-: read-whitespace ( -- str )
+: read-whitespace ( -- string )
[ get-char blank? not ] take-until ;
-: read-whitespace* ( -- )
- read-whitespace drop ;
+: read-whitespace* ( -- ) read-whitespace drop ;
-: read-token ( -- str )
+: read-token ( -- string )
read-whitespace*
[ get-char blank? ] take-until ;
-: read-single-quote ( -- str )
+: read-single-quote ( -- string )
[ get-char CHAR: ' = ] take-until ;
-: read-double-quote ( -- str )
+: read-double-quote ( -- string )
[ get-char CHAR: " = ] take-until ;
-: read-quote ( -- str )
- get-char next* CHAR: ' = [
- read-single-quote
- ] [
- read-double-quote
- ] if next* ;
+: read-quote ( -- string )
+ get-char next* CHAR: ' =
+ [ read-single-quote ] [ read-double-quote ] if next* ;
-: read-key ( -- str )
+: read-key ( -- string )
read-whitespace*
- [ get-char CHAR: = = get-char blank? or ] take-until ;
+ [ get-char [ CHAR: = = ] [ blank? ] bi or ] take-until ;
: read-= ( -- )
read-whitespace*
[ get-char CHAR: = = ] take-until drop next* ;
-: read-value ( -- str )
+: read-value ( -- string )
read-whitespace*
- get-char quote? [
- read-quote
- ] [
- read-token
- ] if ;
+ get-char quote? [ read-quote ] [ read-token ] if
+ [ blank? ] trim ;
: read-comment ( -- )
"-->" take-string* make-comment-tag push-tag ;
[ get-char CHAR: > = get-char CHAR: < = or ] take-until
get-char CHAR: < = [ next* ] unless ;
-: read-< ( -- str )
+: read-< ( -- string )
next* get-char CHAR: ! = [
read-bang f
] [
read-tag
] if ;
-: read-until-< ( -- str )
+: read-until-< ( -- string )
[ get-char CHAR: < = ] take-until ;
: parse-text ( -- )
] string-parse ;
: parse-tag ( -- )
- read-< dup empty? [
- drop
- ] [
+ read-< [
(parse-tag) make-tag push-tag
- ] if ;
+ ] unless-empty ;
: (parse-html) ( -- )
get-next [
] when ;
: tag-parse ( quot -- vector )
- [
- V{ } clone tagstack set
- string-parse
- ] with-scope ;
+ V{ } clone tagstack [ string-parse ] with-variable ;
: parse-html ( string -- vector )
- [
- (parse-html)
- tagstack get
- ] tag-parse ;
+ [ (parse-html) tagstack get ] tag-parse ;
-USING: assocs html.parser html.parser.utils combinators
+USING: accessors assocs html.parser html.parser.utils combinators
continuations hashtables
hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting
strings ;
IN: html.parser.printer
-SYMBOL: no-section
-SYMBOL: html
-SYMBOL: head
-SYMBOL: body
-TUPLE: state section ;
-
-! TUPLE: text bold? underline? strikethrough? ;
-
-TUPLE: text-printer ;
-TUPLE: ui-printer ;
-TUPLE: src-printer ;
-TUPLE: html-prettyprinter ;
-UNION: printer text-printer ui-printer src-printer html-prettyprinter ;
-HOOK: print-tag printer ( tag -- )
-HOOK: print-text-tag printer ( tag -- )
-HOOK: print-comment-tag printer ( tag -- )
-HOOK: print-dtd-tag printer ( tag -- )
-HOOK: print-opening-named-tag printer ( tag -- )
-HOOK: print-closing-named-tag printer ( tag -- )
-
-: print-tags ( vector -- )
- [ print-tag ] each ;
+SYMBOL: printer
-: html-text. ( vector -- )
- [
- T{ text-printer } printer set
- print-tags
- ] with-scope ;
+TUPLE: html-printer ;
+TUPLE: text-printer < html-printer ;
+TUPLE: src-printer < html-printer ;
+TUPLE: html-prettyprinter < html-printer ;
-: html-src. ( vector -- )
- [
- T{ src-printer } printer set
- print-tags
- ] with-scope ;
+HOOK: print-text-tag html-printer ( tag -- )
+HOOK: print-comment-tag html-printer ( tag -- )
+HOOK: print-dtd-tag html-printer ( tag -- )
+HOOK: print-opening-tag html-printer ( tag -- )
+HOOK: print-closing-tag html-printer ( tag -- )
-M: printer print-text-tag ( tag -- )
- tag-text write ;
+ERROR: unknown-tag-error tag ;
-M: printer print-comment-tag ( tag -- )
- "<!--" write
- tag-text write
- "-->" write ;
+: print-tag ( tag -- )
+ {
+ { [ dup name>> text = ] [ print-text-tag ] }
+ { [ dup name>> comment = ] [ print-comment-tag ] }
+ { [ dup name>> dtd = ] [ print-dtd-tag ] }
+ { [ dup [ name>> string? ] [ closing?>> ] bi and ]
+ [ print-closing-tag ] }
+ { [ dup name>> string? ]
+ [ print-opening-tag ] }
+ [ unknown-tag-error ]
+ } cond ;
-M: printer print-dtd-tag ( tag -- )
- "<!" write
- tag-text write
- ">" write ;
+: print-tags ( vector -- ) [ print-tag ] each ;
+
+: html-text. ( vector -- )
+ T{ text-printer } html-printer [ print-tags ] with-variable ;
-M: printer print-opening-named-tag ( tag -- )
- dup tag-name {
- { "html" [ drop ] }
- { "head" [ drop ] }
- { "body" [ drop ] }
- { "title" [ "Title: " write tag-text print ] }
- } case ;
+: html-src. ( vector -- )
+ T{ src-printer } html-printer [ print-tags ] with-variable ;
+
+M: html-printer print-text-tag ( tag -- ) text>> write ;
-M: printer print-closing-named-tag ( tag -- )
- drop ;
+M: html-printer print-comment-tag ( tag -- )
+ "<!--" write text>> write "-->" write ;
+
+M: html-printer print-dtd-tag ( tag -- )
+ "<!" write text>> write ">" write ;
: print-attributes ( hashtable -- )
- [
- swap bl write "=" write ?quote write
- ] assoc-each ;
+ [ [ bl write "=" write ] [ ?quote write ] bi* ] assoc-each ;
-M: src-printer print-opening-named-tag ( tag -- )
+M: src-printer print-opening-tag ( tag -- )
"<" write
- [ tag-name write ]
- [ tag-attributes dup assoc-empty? [ drop ] [ print-attributes ] if ] bi
+ [ name>> write ]
+ [ attributes>> dup assoc-empty? [ drop ] [ print-attributes ] if ] bi
">" write ;
-M: src-printer print-closing-named-tag ( tag -- )
+M: src-printer print-closing-tag ( tag -- )
"</" write
- tag-name write
+ name>> write
">" write ;
SYMBOL: tab-width
SYMBOL: #indentations
+SYMBOL: tagstack
-: html-pp ( vector -- )
+: prettyprint-html ( vector -- )
[
- 0 #indentations set
+ T{ html-prettyprinter } printer set
+ V{ } clone tagstack set
2 tab-width set
-
+ 0 #indentations set
+ print-tags
] with-scope ;
: print-tabs ( -- )
tab-width get #indentations get * CHAR: \s <repetition> write ;
-M: html-prettyprinter print-opening-named-tag ( tag -- )
+M: html-prettyprinter print-opening-tag ( tag -- )
print-tabs "<" write
- tag-name write
+ name>> write
">\n" write ;
-M: html-prettyprinter print-closing-named-tag ( tag -- )
+M: html-prettyprinter print-closing-tag ( tag -- )
"</" write
- tag-name write
+ name>> write
">" write ;
-
-ERROR: unknown-tag-error tag ;
-
-M: printer print-tag ( tag -- )
- {
- { [ dup tag-name text = ] [ print-text-tag ] }
- { [ dup tag-name comment = ] [ print-comment-tag ] }
- { [ dup tag-name dtd = ] [ print-dtd-tag ] }
- { [ dup tag-name string? over tag-closing? and ]
- [ print-closing-named-tag ] }
- { [ dup tag-name string? ]
- [ print-opening-named-tag ] }
- [ unknown-tag-error ]
- } cond ;
-
-! SYMBOL: tablestack
-! : with-html-printer ( vector quot -- )
- ! [ V{ } clone tablestack set ] with-scope ;
-
-! { { 1 2 } { 3 4 } }
-! H{ { table-gap { 10 10 } } } [
- ! [ [ [ [ . ] with-cell ] each ] with-row ] each
-! ] tabular-output
state-parser strings sequences.lib ;
IN: html.parser.utils
-: string-parse-end? ( -- ? )
- get-next not ;
+: string-parse-end? ( -- ? ) get-next not ;
: take-string* ( match -- string )
dup length <circular-string>
[ ?head drop ] [ ?tail drop ] bi ;
: single-quote ( str -- newstr )
- >r "'" r> "'" 3append ;
+ "'" swap "'" 3append ;
: double-quote ( str -- newstr )
- >r "\"" r> "\"" 3append ;
+ "\"" swap "\"" 3append ;
: quote ( str -- newstr )
CHAR: ' over member?
[ double-quote ] [ single-quote ] if ;
: quoted? ( str -- ? )
- [ [ first ] [ peek ] bi [ = ] keep "'\"" member? and ] [ f ] if-seq ;
+ [ f ]
+ [ [ first ] [ peek ] bi [ = ] keep "'\"" member? and ] if-empty ;
: ?quote ( str -- newstr )
dup quoted? [ quote ] unless ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types assocs combinators destructors
+kernel math math.bitfields math.parser sequences summary system
+vocabs.loader ;
+IN: io.serial
+
+TUPLE: serial stream path baud
+ termios iflag oflag cflag lflag ;
+
+ERROR: invalid-baud baud ;
+M: invalid-baud summary ( invalid-baud -- string )
+ "Baud rate "
+ swap baud>> number>string
+ " not supported" 3append ;
+
+HOOK: lookup-baud os ( m -- n )
+HOOK: open-serial os ( serial -- stream )
+
+{
+ { [ os unix? ] [ "io.serial.unix" ] }
+} cond require
--- /dev/null
+Serial port library
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel math.bitfields sequences system io.serial ;
+IN: io.serial.unix
+
+M: bsd lookup-baud ( m -- n )
+ dup {
+ 0 50 75 110 134 150 200 300 600 1200 1800 2400 4800
+ 7200 9600 14400 19200 28800 38400 57600 76800 115200
+ 230400 460800 921600
+ } member? [ invalid-baud ] unless ;
+
+: TCSANOW 0 ; inline
+: TCSADRAIN 1 ; inline
+: TCSAFLUSH 2 ; inline
+: TCSASOFT HEX: 10 ; inline
+
+: TCIFLUSH 1 ; inline
+: TCOFLUSH 2 ; inline
+: TCIOFLUSH 3 ; inline
+: TCOOFF 1 ; inline
+: TCOON 2 ; inline
+: TCIOFF 3 ; inline
+: TCION 4 ; inline
+
+! iflags
+: IGNBRK HEX: 00000001 ; inline
+: BRKINT HEX: 00000002 ; inline
+: IGNPAR HEX: 00000004 ; inline
+: PARMRK HEX: 00000008 ; inline
+: INPCK HEX: 00000010 ; inline
+: ISTRIP HEX: 00000020 ; inline
+: INLCR HEX: 00000040 ; inline
+: IGNCR HEX: 00000080 ; inline
+: ICRNL HEX: 00000100 ; inline
+: IXON HEX: 00000200 ; inline
+: IXOFF HEX: 00000400 ; inline
+: IXANY HEX: 00000800 ; inline
+: IMAXBEL HEX: 00002000 ; inline
+: IUTF8 HEX: 00004000 ; inline
+
+! oflags
+: OPOST HEX: 00000001 ; inline
+: ONLCR HEX: 00000002 ; inline
+: OXTABS HEX: 00000004 ; inline
+: ONOEOT HEX: 00000008 ; inline
+
+! cflags
+: CIGNORE HEX: 00000001 ; inline
+: CSIZE HEX: 00000300 ; inline
+: CS5 HEX: 00000000 ; inline
+: CS6 HEX: 00000100 ; inline
+: CS7 HEX: 00000200 ; inline
+: CS8 HEX: 00000300 ; inline
+: CSTOPB HEX: 00000400 ; inline
+: CREAD HEX: 00000800 ; inline
+: PARENB HEX: 00001000 ; inline
+: PARODD HEX: 00002000 ; inline
+: HUPCL HEX: 00004000 ; inline
+: CLOCAL HEX: 00008000 ; inline
+: CCTS_OFLOW HEX: 00010000 ; inline
+: CRTS_IFLOW HEX: 00020000 ; inline
+: CRTSCTS { CCTS_OFLOW CRTS_IFLOW } flags ; inline
+: CDTR_IFLOW HEX: 00040000 ; inline
+: CDSR_OFLOW HEX: 00080000 ; inline
+: CCAR_OFLOW HEX: 00100000 ; inline
+: MDMBUF HEX: 00100000 ; inline
+
+! lflags
+: ECHOKE HEX: 00000001 ; inline
+: ECHOE HEX: 00000002 ; inline
+: ECHOK HEX: 00000004 ; inline
+: ECHO HEX: 00000008 ; inline
+: ECHONL HEX: 00000010 ; inline
+: ECHOPRT HEX: 00000020 ; inline
+: ECHOCTL HEX: 00000040 ; inline
+: ISIG HEX: 00000080 ; inline
+: ICANON HEX: 00000100 ; inline
+: ALTWERASE HEX: 00000200 ; inline
+: IEXTEN HEX: 00000400 ; inline
+: EXTPROC HEX: 00000800 ; inline
+: TOSTOP HEX: 00400000 ; inline
+: FLUSHO HEX: 00800000 ; inline
+: NOKERNINFO HEX: 02000000 ; inline
+: PENDIN HEX: 20000000 ; inline
+: NOFLSH HEX: 80000000 ; inline
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs alien.syntax kernel io.serial system unix ;
+IN: io.serial.unix
+
+: TCSANOW 0 ; inline
+: TCSADRAIN 1 ; inline
+: TCSAFLUSH 2 ; inline
+
+: TCIFLUSH 0 ; inline
+: TCOFLUSH 1 ; inline
+: TCIOFLUSH 2 ; inline
+
+: TCOOFF 0 ; inline
+: TCOON 1 ; inline
+: TCIOFF 2 ; inline
+: TCION 3 ; inline
+
+! iflag
+: IGNBRK OCT: 0000001 ; inline
+: BRKINT OCT: 0000002 ; inline
+: IGNPAR OCT: 0000004 ; inline
+: PARMRK OCT: 0000010 ; inline
+: INPCK OCT: 0000020 ; inline
+: ISTRIP OCT: 0000040 ; inline
+: INLCR OCT: 0000100 ; inline
+: IGNCR OCT: 0000200 ; inline
+: ICRNL OCT: 0000400 ; inline
+: IUCLC OCT: 0001000 ; inline
+: IXON OCT: 0002000 ; inline
+: IXANY OCT: 0004000 ; inline
+: IXOFF OCT: 0010000 ; inline
+: IMAXBEL OCT: 0020000 ; inline
+: IUTF8 OCT: 0040000 ; inline
+
+! oflag
+: OPOST OCT: 0000001 ; inline
+: OLCUC OCT: 0000002 ; inline
+: ONLCR OCT: 0000004 ; inline
+: OCRNL OCT: 0000010 ; inline
+: ONOCR OCT: 0000020 ; inline
+: ONLRET OCT: 0000040 ; inline
+: OFILL OCT: 0000100 ; inline
+: OFDEL OCT: 0000200 ; inline
+: NLDLY OCT: 0000400 ; inline
+: NL0 OCT: 0000000 ; inline
+: NL1 OCT: 0000400 ; inline
+: CRDLY OCT: 0003000 ; inline
+: CR0 OCT: 0000000 ; inline
+: CR1 OCT: 0001000 ; inline
+: CR2 OCT: 0002000 ; inline
+: CR3 OCT: 0003000 ; inline
+: TABDLY OCT: 0014000 ; inline
+: TAB0 OCT: 0000000 ; inline
+: TAB1 OCT: 0004000 ; inline
+: TAB2 OCT: 0010000 ; inline
+: TAB3 OCT: 0014000 ; inline
+: BSDLY OCT: 0020000 ; inline
+: BS0 OCT: 0000000 ; inline
+: BS1 OCT: 0020000 ; inline
+: FFDLY OCT: 0100000 ; inline
+: FF0 OCT: 0000000 ; inline
+: FF1 OCT: 0100000 ; inline
+
+! cflags
+: CSIZE OCT: 0000060 ; inline
+: CS5 OCT: 0000000 ; inline
+: CS6 OCT: 0000020 ; inline
+: CS7 OCT: 0000040 ; inline
+: CS8 OCT: 0000060 ; inline
+: CSTOPB OCT: 0000100 ; inline
+: CREAD OCT: 0000200 ; inline
+: PARENB OCT: 0000400 ; inline
+: PARODD OCT: 0001000 ; inline
+: HUPCL OCT: 0002000 ; inline
+: CLOCAL OCT: 0004000 ; inline
+: CIBAUD OCT: 002003600000 ; inline
+: CRTSCTS OCT: 020000000000 ; inline
+
+! lflags
+: ISIG OCT: 0000001 ; inline
+: ICANON OCT: 0000002 ; inline
+: XCASE OCT: 0000004 ; inline
+: ECHO OCT: 0000010 ; inline
+: ECHOE OCT: 0000020 ; inline
+: ECHOK OCT: 0000040 ; inline
+: ECHONL OCT: 0000100 ; inline
+: NOFLSH OCT: 0000200 ; inline
+: TOSTOP OCT: 0000400 ; inline
+: ECHOCTL OCT: 0001000 ; inline
+: ECHOPRT OCT: 0002000 ; inline
+: ECHOKE OCT: 0004000 ; inline
+: FLUSHO OCT: 0010000 ; inline
+: PENDIN OCT: 0040000 ; inline
+: IEXTEN OCT: 0100000 ; inline
+
+M: linux lookup-baud ( n -- n )
+ dup H{
+ { 0 OCT: 0000000 }
+ { 50 OCT: 0000001 }
+ { 75 OCT: 0000002 }
+ { 110 OCT: 0000003 }
+ { 134 OCT: 0000004 }
+ { 150 OCT: 0000005 }
+ { 200 OCT: 0000006 }
+ { 300 OCT: 0000007 }
+ { 600 OCT: 0000010 }
+ { 1200 OCT: 0000011 }
+ { 1800 OCT: 0000012 }
+ { 2400 OCT: 0000013 }
+ { 4800 OCT: 0000014 }
+ { 9600 OCT: 0000015 }
+ { 19200 OCT: 0000016 }
+ { 38400 OCT: 0000017 }
+ { 57600 OCT: 0010001 }
+ { 115200 OCT: 0010002 }
+ { 230400 OCT: 0010003 }
+ { 460800 OCT: 0010004 }
+ { 500000 OCT: 0010005 }
+ { 576000 OCT: 0010006 }
+ { 921600 OCT: 0010007 }
+ { 1000000 OCT: 0010010 }
+ { 1152000 OCT: 0010011 }
+ { 1500000 OCT: 0010012 }
+ { 2000000 OCT: 0010013 }
+ { 2500000 OCT: 0010014 }
+ { 3000000 OCT: 0010015 }
+ { 3500000 OCT: 0010016 }
+ { 4000000 OCT: 0010017 }
+ } at* [ nip ] [ drop invalid-baud ] if ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel sequences system ;
+IN: io.serial.unix.termios
+
+: NCCS 20 ; inline
+
+TYPEDEF: uint tcflag_t
+TYPEDEF: uchar cc_t
+TYPEDEF: uint speed_t
+
+C-STRUCT: termios
+ { "tcflag_t" "iflag" } ! input mode flags
+ { "tcflag_t" "oflag" } ! output mode flags
+ { "tcflag_t" "cflag" } ! control mode flags
+ { "tcflag_t" "lflag" } ! local mode flags
+ { { "cc_t" NCCS } "cc" } ! control characters
+ { "speed_t" "ispeed" } ! input speed
+ { "speed_t" "ospeed" } ; ! output speed
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel system unix ;
+IN: io.serial.unix.termios
+
+: NCCS 32 ; inline
+
+TYPEDEF: uchar cc_t
+TYPEDEF: uint speed_t
+TYPEDEF: uint tcflag_t
+
+C-STRUCT: termios
+ { "tcflag_t" "iflag" } ! input mode flags
+ { "tcflag_t" "oflag" } ! output mode flags
+ { "tcflag_t" "cflag" } ! control mode flags
+ { "tcflag_t" "lflag" } ! local mode flags
+ { "cc_t" "line" } ! line discipline
+ { { "cc_t" NCCS } "cc" } ! control characters
+ { "speed_t" "ispeed" } ! input speed
+ { "speed_t" "ospeed" } ; ! output speed
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators system vocabs.loader ;
+IN: io.serial.unix.termios
+
+{
+ { [ os linux? ] [ "io.serial.unix.termios.linux" ] }
+ { [ os bsd? ] [ "io.serial.unix.termios.bsd" ] }
+} cond require
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math.bitfields serial serial.unix ;
+IN: io.serial.unix
+
+: serial-obj ( -- obj )
+ serial new
+ "/dev/ttyS0" >>path
+ 19200 >>baud
+ { IGNPAR ICRNL } flags >>iflag
+ { } flags >>oflag
+ { CS8 CLOCAL CREAD } flags >>cflag
+ { ICANON } flags >>lflag ;
+
+: serial-test ( -- serial )
+ serial-obj
+ open-serial
+ dup get-termios >>termios
+ dup configure-termios
+ dup tciflush
+ dup apply-termios ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.syntax combinators io.ports
+io.streams.duplex io.unix.backend system kernel math math.bitfields
+vocabs.loader unix io.serial io.serial.unix.termios ;
+IN: io.serial.unix
+
+<< {
+ { [ os linux? ] [ "io.serial.unix.linux" ] }
+ { [ os bsd? ] [ "io.serial.unix.bsd" ] }
+} cond require >>
+
+FUNCTION: speed_t cfgetispeed ( termios* t ) ;
+FUNCTION: speed_t cfgetospeed ( termios* t ) ;
+FUNCTION: int cfsetispeed ( termios* t, speed_t s ) ;
+FUNCTION: int cfsetospeed ( termios* t, speed_t s ) ;
+FUNCTION: int tcgetattr ( int i1, termios* t ) ;
+FUNCTION: int tcsetattr ( int i1, int i2, termios* t ) ;
+FUNCTION: int tcdrain ( int i1 ) ;
+FUNCTION: int tcflow ( int i1, int i2 ) ;
+FUNCTION: int tcflush ( int i1, int i2 ) ;
+FUNCTION: int tcsendbreak ( int i1, int i2 ) ;
+FUNCTION: void cfmakeraw ( termios* t ) ;
+FUNCTION: int cfsetspeed ( termios* t, speed_t s ) ;
+
+: fd>duplex-stream ( fd -- duplex-stream )
+ <fd> init-fd
+ [ <input-port> ] [ <output-port> ] bi <duplex-stream> ;
+
+: open-rw ( path -- fd ) O_RDWR file-mode open-file ;
+: <file-rw> ( path -- stream ) open-rw fd>duplex-stream ;
+
+M: unix open-serial ( serial -- serial' )
+ path>> { O_RDWR O_NOCTTY O_NDELAY } flags file-mode open-file
+ fd>duplex-stream ;
+
+: serial-fd ( serial -- fd )
+ stream>> in>> handle>> fd>> ;
+
+: get-termios ( serial -- termios )
+ serial-fd
+ "termios" <c-object> [ tcgetattr io-error ] keep ;
+
+: configure-termios ( serial -- )
+ dup termios>>
+ {
+ [ [ iflag>> ] dip over [ set-termios-iflag ] [ 2drop ] if ]
+ [ [ oflag>> ] dip over [ set-termios-oflag ] [ 2drop ] if ]
+ [
+ [
+ [ cflag>> 0 or ] [ baud>> lookup-baud ] bi bitor
+ ] dip set-termios-cflag
+ ]
+ [ [ lflag>> ] dip over [ set-termios-lflag ] [ 2drop ] if ]
+ } 2cleave ;
+
+: tciflush ( serial -- )
+ serial-fd TCIFLUSH tcflush io-error ;
+
+: apply-termios ( serial -- )
+ [ serial-fd TCSANOW ]
+ [ termios>> ] bi tcsetattr io-error ;
USING: kernel tools.test accessors arrays sequences qualified
- io.streams.string io.streams.duplex namespaces threads
+ io io.streams.duplex namespaces threads
calendar irc.client.private irc.client irc.messages.private
concurrency.mailboxes classes assocs combinators ;
EXCLUDE: irc.messages => join ;
RENAME: join irc.messages => join_
IN: irc.client.tests
-! Utilities
-: <test-stream> ( lines -- stream )
- "\n" join <string-reader> <string-writer> <duplex-stream> ;
+! Streams for testing
+TUPLE: mb-writer lines last-line disposed ;
+TUPLE: mb-reader lines disposed ;
+: <mb-writer> ( -- mb-writer ) V{ } clone V{ } clone f mb-writer boa ;
+: <mb-reader> ( -- mb-reader ) <mailbox> f mb-reader boa ;
+: push-line ( line test-reader-stream -- ) lines>> mailbox-put ;
+: <test-stream> ( -- stream ) <mb-reader> <mb-writer> <duplex-stream> ;
+M: mb-writer stream-write ( line mb-writer -- ) last-line>> push ;
+M: mb-writer stream-flush ( mb-writer -- ) drop ;
+M: mb-reader stream-readln ( mb-reader -- str/f ) lines>> mailbox-get ;
+M: mb-writer stream-nl ( mb-writer -- )
+ [ [ last-line>> concat ] [ lines>> ] bi push ] keep
+ V{ } clone >>last-line drop ;
-: make-client ( lines -- irc-client )
- "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
- swap [ 2nip <test-stream> f ] curry >>connect ;
+: spawn-client ( lines listeners -- irc-client )
+ "someserver" irc-port "factorbot" f <irc-profile>
+ <irc-client>
+ t >>is-running
+ <test-stream> >>stream
+ dup [ spawn-irc yield ] with-irc-client ;
-: set-nick ( irc-client nickname -- )
- swap profile>> (>>nickname) ;
+! to be used inside with-irc-client quotations
+: %add-named-listener ( listener -- ) [ name>> ] keep set+run-listener ;
+: %join ( channel -- ) <irc-channel-listener> irc> add-listener ;
+: %push-line ( line -- ) irc> stream>> in>> push-line yield ;
-: with-dummy-client ( irc-client quot -- )
- [ current-irc-client ] dip with-variable ; inline
+: read-matching-message ( listener quot: ( msg -- ? ) -- irc-message )
+ [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
-{ "" } make-client dup "factorbot" set-nick [
- { t } [ irc> profile>> nickname>> me? ] unit-test
+: with-irc ( quot: ( -- ) -- )
+ [ spawn-client ] dip [ f %push-line ] compose with-irc-client ; inline
- { "factorbot" } [ irc> profile>> nickname>> ] unit-test
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! TESTS
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
+[ { t } [ irc> profile>> nickname>> me? ] unit-test
- { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
- parse-irc-line irc-message-origin ] unit-test
+ { "factorbot" } [ irc> profile>> nickname>> ] unit-test
- { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
- parse-irc-line irc-message-origin ] unit-test
-] with-dummy-client
+ { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
+
+ { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
+ parse-irc-line forward-name ] unit-test
+
+ { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
+ parse-irc-line forward-name ] unit-test
+] with-irc
! Test login and nickname set
-{ "factorbot" } [
- { "NOTICE AUTH :*** Looking up your hostname..."
- "NOTICE AUTH :*** Checking ident"
- "NOTICE AUTH :*** Found your hostname"
- "NOTICE AUTH :*** No identd (auth) response"
- ":some.where 001 factorbot :Welcome factorbot"
- } make-client
- { [ connect-irc ]
- [ drop 0.1 seconds sleep ]
- [ profile>> nickname>> ]
- [ terminate-irc ]
- } cleave ] unit-test
-
-{ join_ "#factortest" } [
- { ":factorbot!n=factorbo@some.where JOIN :#factortest"
- ":ircserver.net MODE #factortest +ns"
- ":ircserver.net 353 factorbot @ #factortest :@factorbot "
- ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
- ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
- } make-client
- { [ "factorbot" set-nick ]
- [ connect-irc ]
- [ drop 0.1 seconds sleep ]
- [ join-messages>> 0.1 seconds mailbox-get-timeout ]
- [ terminate-irc ]
- } cleave
- [ class ] [ trailing>> ] bi ] unit-test
-
-{ +join+ "somebody" } [
- { ":somebody!n=somebody@some.where JOIN :#factortest" } make-client
- { [ "factorbot" set-nick ]
- [ listeners>>
- [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
- [ connect-irc ]
- [ listeners>> [ "#factortest" ] dip at
- [ read-message drop ] [ read-message drop ] [ read-message ] tri ]
- [ terminate-irc ]
- } cleave
- [ action>> ] [ nick>> ] bi
- ] unit-test
-
-{ privmsg "#factortest" "hello" } [
- { ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" } make-client
- { [ "factorbot" set-nick ]
- [ listeners>>
- [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
- [ connect-irc ]
- [ listeners>> [ "#factortest" ] dip at
- [ read-message drop ] [ read-message ] bi ]
- [ terminate-irc ]
- } cleave
- [ class ] [ name>> ] [ trailing>> ] tri
- ] unit-test
-
-{ privmsg "factorbot" "hello" } [
- { ":somedude!n=user@isp.net PRIVMSG factorbot :hello" } make-client
- { [ "factorbot" set-nick ]
- [ listeners>>
- [ "somedude" [ <irc-nick-listener> ] keep ] dip set-at ]
- [ connect-irc ]
- [ listeners>> [ "somedude" ] dip at
- [ read-message drop ] [ read-message ] bi ]
- [ terminate-irc ]
- } cleave
- [ class ] [ name>> ] [ trailing>> ] tri
- ] unit-test
-
-! Participants lists tests
-{ H{ { "somedude" +normal+ } } } [
- { ":somedude!n=user@isp.net JOIN :#factortest" } make-client
- { [ "factorbot" set-nick ]
- [ listeners>>
- [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
- [ connect-irc ]
- [ drop 0.1 seconds sleep ]
- [ listeners>> [ "#factortest" ] dip at participants>> ]
- [ terminate-irc ]
- } cleave
- ] unit-test
-
-{ H{ { "somedude2" +normal+ } } } [
- { ":somedude!n=user@isp.net PART #factortest" } make-client
- { [ "factorbot" set-nick ]
- [ listeners>>
- [ "#factortest" [ <irc-channel-listener>
- H{ { "somedude2" +normal+ }
- { "somedude" +normal+ } } clone >>participants ] keep
- ] dip set-at ]
- [ connect-irc ]
- [ drop 0.1 seconds sleep ]
- [ listeners>> [ "#factortest" ] dip at participants>> ]
- [ terminate-irc ]
- } cleave
- ] unit-test
-
-{ H{ { "somedude2" +normal+ } } } [
- { ":somedude!n=user@isp.net QUIT" } make-client
- { [ "factorbot" set-nick ]
- [ listeners>>
- [ "#factortest" [ <irc-channel-listener>
- H{ { "somedude2" +normal+ }
- { "somedude" +normal+ } } clone >>participants ] keep
- ] dip set-at ]
- [ connect-irc ]
- [ drop 0.1 seconds sleep ]
- [ listeners>> [ "#factortest" ] dip at participants>> ]
- [ terminate-irc ]
- } cleave
- ] unit-test
-
-{ H{ { "somedude2" +normal+ } } } [
- { ":somedude2!n=user2@isp.net KICK #factortest somedude" } make-client
- { [ "factorbot" set-nick ]
- [ listeners>>
- [ "#factortest" [ <irc-channel-listener>
- H{ { "somedude2" +normal+ }
- { "somedude" +normal+ } } clone >>participants ] keep
- ] dip set-at ]
- [ connect-irc ]
- [ drop 0.1 seconds sleep ]
- [ listeners>> [ "#factortest" ] dip at participants>> ]
- [ terminate-irc ]
- } cleave
- ] unit-test
+[ { "factorbot2" } [
+ ":some.where 001 factorbot2 :Welcome factorbot2" %push-line
+ irc> profile>> nickname>>
+ ] unit-test
+] with-irc
+
+[ { join_ "#factortest" } [
+ { ":factorbot!n=factorbo@some.where JOIN :#factortest"
+ ":ircserver.net 353 factorbot @ #factortest :@factorbot "
+ ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
+ ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
+ } [ %push-line ] each
+ irc> join-messages>> 0.1 seconds mailbox-get-timeout
+ [ class ] [ trailing>> ] bi
+ ] unit-test
+] with-irc
+
+[ { T{ participant-changed f "somebody" +join+ } } [
+ "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+ ":somebody!n=somebody@some.where JOIN :#factortest" %push-line
+ [ participant-changed? ] read-matching-message
+ ] unit-test
+] with-irc
+
+[ { privmsg "#factortest" "hello" } [
+ "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+ ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line
+ [ privmsg? ] read-matching-message
+ [ class ] [ name>> ] [ trailing>> ] tri
+ ] unit-test
+] with-irc
+
+[ { privmsg "factorbot" "hello" } [
+ "somedude" <irc-nick-listener> [ %add-named-listener ] keep
+ ":somedude!n=user@isp.net PRIVMSG factorbot :hello" %push-line
+ [ privmsg? ] read-matching-message
+ [ class ] [ name>> ] [ trailing>> ] tri
+ ] unit-test
+] with-irc
+
+[ { mode } [
+ "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+ ":ircserver.net MODE #factortest +ns" %push-line
+ [ mode? ] read-matching-message class
+ ] unit-test
+] with-irc
+
+! Participant lists tests
+[ { H{ { "somedude" +normal+ } } } [
+ "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+ ":somedude!n=user@isp.net JOIN :#factortest" %push-line
+ participants>>
+ ] unit-test
+] with-irc
+
+[ { H{ { "somedude2" +normal+ } } } [
+ "#factortest" <irc-channel-listener>
+ H{ { "somedude2" +normal+ }
+ { "somedude" +normal+ } } clone >>participants
+ [ %add-named-listener ] keep
+ ":somedude!n=user@isp.net PART #factortest" %push-line
+ participants>>
+ ] unit-test
+] with-irc
+
+[ { H{ { "somedude2" +normal+ } } } [
+ "#factortest" <irc-channel-listener>
+ H{ { "somedude2" +normal+ }
+ { "somedude" +normal+ } } clone >>participants
+ [ %add-named-listener ] keep
+ ":somedude!n=user@isp.net QUIT" %push-line
+ participants>>
+ ] unit-test
+] with-irc
+
+[ { H{ { "somedude2" +normal+ } } } [
+ "#factortest" <irc-channel-listener>
+ H{ { "somedude2" +normal+ }
+ { "somedude" +normal+ } } clone >>participants
+ [ %add-named-listener ] keep
+ ":somedude2!n=user2@isp.net KICK #factortest somedude" %push-line
+ participants>>
+ ] unit-test
+] with-irc
+
+[ { H{ { "somedude2" +normal+ } } } [
+ "#factortest" <irc-channel-listener>
+ H{ { "somedude" +normal+ } } clone >>participants
+ [ %add-named-listener ] keep
+ ":somedude!n=user2@isp.net NICK :somedude2" %push-line
+ participants>>
+ ] unit-test
+] with-irc
! Namelist change notification
-{ T{ participant-changed f f f } } [
- { ":ircserver.net 353 factorbot @ #factortest :@factorbot "
- ":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client
- { [ "factorbot" set-nick ]
- [ listeners>>
- [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
- [ connect-irc ]
- [ drop 0.1 seconds sleep ]
- [ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ]
- [ terminate-irc ]
- } cleave
- ] unit-test
-
-{ T{ participant-changed f "somedude" +part+ } } [
- { ":somedude!n=user@isp.net QUIT" } make-client
- { [ "factorbot" set-nick ]
- [ listeners>>
- [ "#factortest" [ <irc-channel-listener>
- H{ { "somedude" +normal+ } } clone >>participants ] keep
- ] dip set-at ]
- [ connect-irc ]
- [ drop 0.1 seconds sleep ]
- [ listeners>> [ "#factortest" ] dip at
- [ read-message drop ] [ read-message drop ] [ read-message ] tri ]
- [ terminate-irc ]
- } cleave
- ] unit-test
\ No newline at end of file
+[ { T{ participant-changed f f f f } } [
+ "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+ ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
+ ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
+ [ participant-changed? ] read-matching-message
+ ] unit-test
+] with-irc
+
+[ { T{ participant-changed f "somedude" +part+ f } } [
+ "#factortest" <irc-channel-listener>
+ H{ { "somedude" +normal+ } } clone >>participants
+ [ %add-named-listener ] keep
+ ":somedude!n=user@isp.net QUIT" %push-line
+ [ participant-changed? ] read-matching-message
+ ] unit-test
+] with-irc
+
+[ { T{ participant-changed f "somedude" +nick+ "somedude2" } } [
+ "#factortest" <irc-channel-listener>
+ H{ { "somedude" +normal+ } } clone >>participants
+ [ %add-named-listener ] keep
+ ":somedude!n=user2@isp.net NICK :somedude2" %push-line
+ [ participant-changed? ] read-matching-message
+ ] unit-test
+] with-irc
USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
accessors destructors namespaces io assocs arrays qualified fry
continuations threads strings classes combinators splitting hashtables
- ascii irc.messages irc.messages.private ;
+ ascii irc.messages ;
RENAME: join sequences => sjoin
EXCLUDE: sequences => join ;
IN: irc.client
SYMBOL: +join+
SYMBOL: +part+
SYMBOL: +mode+
+SYMBOL: +nick+
! listener objects
: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
! Message objects
! ======================================
-TUPLE: participant-changed nick action ;
+TUPLE: participant-changed nick action parameter ;
C: <participant-changed> participant-changed
SINGLETON: irc-listener-end ! send to a listener to stop its execution
SINGLETON: irc-end ! sent when the client isn't running anymore
SINGLETON: irc-disconnected ! sent when connection is lost
SINGLETON: irc-connected ! sent when connection is established
-UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
: terminate-irc ( irc-client -- )
[ is-running>> ] keep and [
listener> [ +server-listener+ listener> ] unless*
[ to-listener ] [ drop ] if* ;
+M: irc-listener to-listener ( message irc-listener -- )
+ in-messages>> mailbox-put ;
+
: unregister-listener ( name -- )
irc> listeners>>
[ at [ irc-listener-end ] dip to-listener ]
[ delete-at ]
2bi ;
-M: irc-listener to-listener ( message irc-listener -- )
- in-messages>> mailbox-put ;
+: (remove-participant) ( nick listener -- )
+ [ participants>> delete-at ]
+ [ [ +part+ f <participant-changed> ] dip to-listener ] 2bi ;
: remove-participant ( nick channel -- )
- listener> [ participants>> delete-at ] [ drop ] if* ;
+ listener> [ (remove-participant) ] [ drop ] if* ;
: listeners-with-participant ( nick -- seq )
irc> listeners>> values
[ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
with filter ;
+: to-listeners-with-participant ( message nickname -- )
+ listeners-with-participant [ to-listener ] with each ;
+
: remove-participant-from-all ( nick -- )
- dup listeners-with-participant [ participants>> delete-at ] with each ;
+ dup listeners-with-participant [ (remove-participant) ] with each ;
+
+: notify-rename ( newnick oldnick listener -- )
+ [ participant-changed new +nick+ >>action
+ [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-listener ;
+
+: rename-participant ( newnick oldnick listener -- )
+ [ participants>> [ delete-at* drop ] [ [ swap ] dip set-at ] bi ]
+ [ notify-rename ] 3bi ;
+
+: rename-participant-in-all ( oldnick newnick -- )
+ swap dup listeners-with-participant [ rename-participant ] with with each ;
: add-participant ( mode nick channel -- )
- listener> [ participants>> set-at ] [ 2drop ] if* ;
+ listener> [
+ [ participants>> set-at ]
+ [ [ +join+ f <participant-changed> ] dip to-listener ] 2bi
+ ] [ 2drop ] if* ;
DEFER: me?
: maybe-forward-join ( join -- )
- [ prefix>> parse-name me? ] keep and
+ [ irc-message-sender me? ] keep and
[ irc> join-messages>> mailbox-put ] when* ;
! ======================================
: me? ( string -- ? )
irc> profile>> nickname>> = ;
-: irc-message-origin ( irc-message -- name )
- dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
+GENERIC: forward-name ( irc-message -- name )
+M: join forward-name ( join -- name ) trailing>> ;
+M: part forward-name ( part -- name ) channel>> ;
+M: kick forward-name ( kick -- name ) channel>> ;
+M: mode forward-name ( mode -- name ) channel>> ;
+M: privmsg forward-name ( privmsg -- name )
+ dup name>> me? [ irc-message-sender ] [ name>> ] if ;
-: broadcast-message-to-listeners ( message -- )
- irc> listeners>> values [ to-listener ] with each ;
-
-GENERIC: handle-participant-change ( irc-message -- )
+UNION: single-forward join part kick mode privmsg ;
+UNION: multiple-forward nick quit ;
+UNION: broadcast-forward irc-end irc-disconnected irc-connected ;
+GENERIC: forward-message ( irc-message -- )
-M: join handle-participant-change ( join -- )
- [ prefix>> parse-name +join+ <participant-changed> ]
- [ trailing>> ] bi to-listener ;
+M: irc-message forward-message ( irc-message -- )
+ +server-listener+ listener> [ to-listener ] [ drop ] if* ;
-M: part handle-participant-change ( part -- )
- [ prefix>> parse-name +part+ <participant-changed> ]
- [ channel>> ] bi to-listener ;
+M: single-forward forward-message ( forward-single -- )
+ dup forward-name to-listener ;
-M: kick handle-participant-change ( kick -- )
- [ who>> +part+ <participant-changed> ]
- [ channel>> ] bi to-listener ;
+M: multiple-forward forward-message ( multiple-forward -- )
+ dup irc-message-sender to-listeners-with-participant ;
-M: quit handle-participant-change ( quit -- )
- prefix>> parse-name
- [ +part+ <participant-changed> ] [ listeners-with-participant ] bi
- [ to-listener ] with each ;
+M: join forward-message ( join -- )
+ [ maybe-forward-join ] [ call-next-method ] bi ;
+
+M: broadcast-forward forward-message ( irc-broadcasted-message -- )
+ irc> listeners>> values [ to-listener ] with each ;
-GENERIC: handle-incoming-irc ( irc-message -- )
+GENERIC: process-message ( irc-message -- )
-M: irc-message handle-incoming-irc ( irc-message -- )
- +server-listener+ listener> [ to-listener ] [ drop ] if* ;
-
-M: logged-in handle-incoming-irc ( logged-in -- )
+M: object process-message ( object -- )
+ drop ;
+
+M: logged-in process-message ( logged-in -- )
name>> irc> profile>> (>>nickname) ;
-M: ping handle-incoming-irc ( ping -- )
+M: ping process-message ( ping -- )
trailing>> /PONG ;
-M: nick-in-use handle-incoming-irc ( nick-in-use -- )
+M: nick-in-use process-message ( nick-in-use -- )
name>> "_" append /NICK ;
-M: privmsg handle-incoming-irc ( privmsg -- )
- dup irc-message-origin to-listener ;
+M: join process-message ( join -- )
+ [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri add-participant ;
-M: join handle-incoming-irc ( join -- )
- { [ maybe-forward-join ]
- [ dup trailing>> to-listener ]
- [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
- [ handle-participant-change ]
- } cleave ;
+M: part process-message ( part -- )
+ [ irc-message-sender ] [ channel>> ] bi remove-participant ;
-M: part handle-incoming-irc ( part -- )
- [ dup channel>> to-listener ]
- [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ]
- [ handle-participant-change ]
- tri ;
+M: kick process-message ( kick -- )
+ [ [ who>> ] [ channel>> ] bi remove-participant ]
+ [ dup who>> me? [ unregister-listener ] [ drop ] if ]
+ bi ;
-M: kick handle-incoming-irc ( kick -- )
- { [ dup channel>> to-listener ]
- [ [ who>> ] [ channel>> ] bi remove-participant ]
- [ handle-participant-change ]
- [ dup who>> me? [ unregister-listener ] [ drop ] if ]
- } cleave ;
-
-M: quit handle-incoming-irc ( quit -- )
- [ dup prefix>> parse-name listeners-with-participant
- [ to-listener ] with each ]
- [ handle-participant-change ]
- [ prefix>> parse-name remove-participant-from-all ]
- tri ;
+M: quit process-message ( quit -- )
+ irc-message-sender remove-participant-from-all ;
-! FIXME: implement this
-! M: mode handle-incoming-irc ( mode -- ) call-next-method ;
-! M: nick handle-incoming-irc ( nick -- ) call-next-method ;
+M: nick process-message ( nick -- )
+ [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
: >nick/mode ( string -- nick mode )
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
trailing>> [ blank? ] trim " " split
[ >nick/mode 2array ] map >hashtable ;
-M: names-reply handle-incoming-irc ( names-reply -- )
+M: names-reply process-message ( names-reply -- )
[ names-reply>participants ] [ channel>> listener> ] bi [
[ (>>participants) ]
- [ [ f f <participant-changed> ] dip name>> to-listener ] bi
+ [ [ f f
f <participant-changed> ] dip name>> to-listener ] bi
] [ drop ] if* ;
-M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
- broadcast-message-to-listeners ;
+: handle-incoming-irc ( irc-message -- )
+ [ forward-message ] [ process-message ] bi ;
! ======================================
! Client message handling
! ======================================
-GENERIC: handle-outgoing-irc ( obj -- )
-
-M: irc-message handle-outgoing-irc ( irc-message -- )
+: handle-outgoing-irc ( irc-message -- )
irc-message>client-line irc-print ;
! ======================================
in-messages>> [ irc-connected ] dip mailbox-put ;
: with-irc-client ( irc-client quot: ( -- ) -- )
- [ current-irc-client ] dip with-variable ; inline
+ [ \ current-irc-client ] dip with-variable ; inline
PRIVATE>
EXCLUDE: sequences => join ;
IN: irc.messages.tests
-! Parsing tests
+
+{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
+
irc-message new
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
"someuser!n=user@some.where" >>prefix
M: irc-message irc-command-parameters ( irc-message -- seq ) parameters>> ;
M: ping irc-command-parameters ( ping -- seq ) drop { } ;
M: join irc-command-parameters ( join -- seq ) drop { } ;
-M: part irc-command-parameters ( part -- seq ) name>> 1array ;
+M: part irc-command-parameters ( part -- seq ) channel>> 1array ;
M: quit irc-command-parameters ( quit -- seq ) drop { } ;
M: nick irc-command-parameters ( nick -- seq ) drop { } ;
M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ;
PRIVATE>
+UNION: sender-in-prefix privmsg join part quit kick mode nick ;
+GENERIC: irc-message-sender ( irc-message -- sender )
+M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
+ prefix>> parse-name ;
+
: string>irc-message ( string -- object )
dup split-prefix split-trailing
[ [ blank? ] trim " " split unclip swap ] dip
! 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
+USING: accessors kernel arrays 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
+ irc-tab get\r
+ [ window>> client>> profile>> nickname>> <own-message> print-irc ]\r
+ [ listener>> write-message ] 2bi ;\r
+\r
+: join ( string -- )\r
+ irc-tab get window>> join-channel ;\r
+\r
+: query ( string -- )\r
+ irc-tab get window>> query-nick ;\r
+\r
+: whois ( string -- )\r
+ "WHOIS" swap { } clone swap <irc-client-message>\r
+ irc-tab get listener>> write-message ;\r
\r
: quote ( string -- )\r
drop ; ! THIS WILL CHANGE\r
ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures\r
ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels\r
io io.styles namespaces calendar calendar.format models continuations\r
- irc.client irc.client.private irc.messages irc.messages.private\r
+ irc.client irc.client.private irc.messages\r
irc.ui.commandparser irc.ui.load ;\r
\r
RENAME: join sequences => sjoin\r
\r
SYMBOL: client\r
\r
-TUPLE: ui-window client tabs ;\r
+TUPLE: ui-window < tabbed client ;\r
\r
-TUPLE: irc-tab < frame listener client userlist ;\r
+M: ui-window ungraft*\r
+ client>> terminate-irc ;\r
+\r
+TUPLE: irc-tab < frame listener client window ;\r
\r
: write-color ( str color -- )\r
foreground associate format ;\r
\r
M: privmsg write-irc\r
"<" blue write-color\r
- [ prefix>> parse-name write ] keep\r
+ [ irc-message-sender write ] keep\r
"> " blue write-color\r
trailing>> write ;\r
\r
\r
M: join write-irc\r
"* " dark-green write-color\r
- prefix>> parse-name write\r
+ irc-message-sender write\r
" has entered the channel." dark-green write-color ;\r
\r
M: part write-irc\r
"* " dark-red write-color\r
- [ prefix>> parse-name write ] keep\r
+ [ irc-message-sender write ] keep\r
" has left the channel" dark-red write-color\r
trailing>> dot-or-parens dark-red write-color ;\r
\r
M: quit write-irc\r
"* " dark-red write-color\r
- [ prefix>> parse-name write ] keep\r
+ [ irc-message-sender write ] keep\r
" has left IRC" dark-red write-color\r
trailing>> dot-or-parens dark-red write-color ;\r
\r
M: kick write-irc\r
"* " dark-red write-color\r
- [ prefix>> parse-name write ] keep\r
+ [ irc-message-sender write ] keep\r
" has kicked " dark-red write-color\r
[ who>> write ] keep\r
" from the channel" dark-red write-color\r
\r
M: mode write-irc\r
"* " blue write-color\r
- [ prefix>> parse-name write ] keep\r
+ [ irc-message-sender write ] keep\r
" has applied mode " blue write-color\r
[ full-mode write ] keep\r
" to " blue write-color\r
\r
M: nick write-irc\r
"* " blue write-color\r
- [ prefix>> parse-name write ] keep\r
+ [ irc-message-sender write ] keep\r
" is now known as " blue write-color\r
trailing>> write ;\r
\r
M: irc-message write-irc\r
drop ; ! catch all unimplemented writes, THIS WILL CHANGE \r
\r
-: time-happened ( irc-message -- timestamp )\r
- [ timestamp>> ] [ 2drop now ] recover ;\r
+GENERIC: time-happened ( message -- timestamp )\r
+\r
+M: irc-message time-happened timestamp>> ;\r
+\r
+M: object time-happened drop now ;\r
\r
: print-irc ( irc-message -- )\r
[ time-happened timestamp>hms write " " write ]\r
: add-gadget-color ( pack seq color -- pack )\r
'[ , >>color add-gadget ] each ;\r
\r
-: update-participants ( tab -- )\r
- [ userlist>> [ clear-gadget ] keep ]\r
- [ listener>> participants>> ] bi\r
- [ +operator+ value-labels dark-green add-gadget-color ]\r
- [ +voice+ value-labels blue add-gadget-color ]\r
- [ +normal+ value-labels black add-gadget-color ] tri drop ;\r
-\r
-M: participant-changed handle-inbox\r
- drop update-participants ;\r
-\r
M: object handle-inbox\r
nip print-irc ;\r
\r
<scrolling-pane>\r
[ <pane-stream> swap display ] 2keep ;\r
\r
-TUPLE: irc-editor < editor outstream listener client ;\r
+TUPLE: irc-editor < editor outstream tab ;\r
\r
: <irc-editor> ( tab pane -- tab editor )\r
- over irc-editor new-editor\r
- swap listener>> >>listener swap <pane-stream> >>outstream\r
- over client>> >>client ;\r
+ irc-editor new-editor\r
+ swap <pane-stream> >>outstream ;\r
\r
: editor-send ( irc-editor -- )\r
{ [ outstream>> ]\r
- [ listener>> ]\r
- [ client>> ]\r
+ [ [ irc-tab? ] find-parent ]\r
[ editor-string ]\r
[ "" swap set-editor-string ] } cleave\r
- '[ , listener set , client set , parse-message ] with-output-stream ;\r
+ '[ , irc-tab 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-tab> ( listener client -- irc-tab )\r
- irc-tab new-frame\r
- swap client>> >>client swap >>listener\r
+: new-irc-tab ( listener ui-window class -- irc-tab )\r
+ new-frame\r
+ swap >>window\r
+ swap >>listener\r
<irc-pane> [ <scroller> @center grid-add ] keep\r
<irc-editor> <scroller> @bottom grid-add ;\r
\r
-: <irc-channel-tab> ( listener client -- irc-tab )\r
- <irc-tab>\r
+M: irc-tab graft*\r
+ [ listener>> ] [ window>> client>> ] bi add-listener ;\r
+\r
+M: irc-tab ungraft*\r
+ [ listener>> ] [ window>> client>> ] bi remove-listener ;\r
+\r
+TUPLE: irc-channel-tab < irc-tab userlist ;\r
+\r
+: <irc-channel-tab> ( listener ui-window -- irc-tab )\r
+ irc-channel-tab new-irc-tab\r
<pile> [ <scroller> @right grid-add ] keep >>userlist ;\r
\r
-: <irc-server-tab> ( listener client -- irc-tab )\r
- <irc-tab> ;\r
+: update-participants ( tab -- )\r
+ [ userlist>> [ clear-gadget ] keep ]\r
+ [ listener>> participants>> ] bi\r
+ [ +operator+ value-labels dark-green add-gadget-color ]\r
+ [ +voice+ value-labels blue add-gadget-color ]\r
+ [ +normal+ value-labels black add-gadget-color ] tri drop ;\r
\r
-M: irc-tab graft*\r
- [ listener>> ] [ client>> ] bi add-listener ;\r
+M: participant-changed handle-inbox\r
+ drop update-participants ;\r
\r
-M: irc-tab ungraft*\r
- [ listener>> ] [ client>> ] bi remove-listener ;\r
+TUPLE: irc-server-tab < irc-tab ;\r
+\r
+: <irc-server-tab> ( listener -- irc-tab )\r
+ f irc-server-tab new-irc-tab ;\r
+\r
+: <irc-nick-tab> ( listener ui-window -- irc-tab )\r
+ irc-tab new-irc-tab ;\r
\r
M: irc-tab pref-dim*\r
drop { 480 480 } ;\r
: join-channel ( name ui-window -- )\r
[ dup <irc-channel-listener> ] dip\r
[ <irc-channel-tab> swap ] keep\r
- tabs>> add-page ;\r
+ add-page ;\r
+\r
+: query-nick ( nick ui-window -- )\r
+ [ dup <irc-nick-listener> ] dip\r
+ [ <irc-nick-tab> swap ] keep\r
+ add-page ;\r
\r
: irc-window ( ui-window -- )\r
- [ tabs>> ]\r
+ [ ]\r
[ client>> profile>> server>> ] bi\r
open-window ;\r
\r
: ui-connect ( profile -- ui-window )\r
- <irc-client> ui-window new over >>client swap\r
- [ connect-irc ]\r
- [ [ <irc-server-listener> ] dip add-listener ]\r
- [ listeners>> +server-listener+ swap at over <irc-tab>\r
- "Server" associate <tabbed> >>tabs ] tri ;\r
+ <irc-client>\r
+ { [ [ <irc-server-listener> ] dip add-listener ]\r
+ [ listeners>> +server-listener+ swap at <irc-server-tab> dup\r
+ "Server" associate ui-window new-tabbed [ swap (>>window) ] keep ]\r
+ [ >>client ]\r
+ [ connect-irc ] } cleave ;\r
\r
: server-open ( server port nick password channels -- )\r
[ <irc-profile> ui-connect [ irc-window ] keep ] dip\r
[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test
[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test
-[ { "b" "d" } ] [ { "a" "b" "c" "d" } { 1 3 } reorder ] unit-test
-[ { "a" "b" "c" "d" } ] [ { "a" "b" "c" "d" } { 0 1 2 3 } reorder ] unit-test
-[ { "d" "c" "b" "a" } ] [ { "a" "b" "c" "d" } { 3 2 1 0 } reorder ] unit-test
-[ { "d" "a" "b" "c" } ] [ { "a" "b" "c" "d" } { 3 0 1 2 } reorder ] unit-test
-
[ 1 ] [ 0 factorial ] unit-test
[ 1 ] [ 1 factorial ] unit-test
[ 3628800 ] [ 10 factorial ] unit-test
! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math math.order math.ranges mirrors
-namespaces sequences sorting ;
+namespaces sequences sequences.lib sorting ;
IN: math.combinatorics
<PRIVATE
: permutation-indices ( n seq -- permutation )
length [ factoradic ] dip 0 pad-left >permutation ;
-: reorder ( seq indices -- seq )
- [ [ over nth , ] each drop ] { } make ;
-
PRIVATE>
: factorial ( n -- n! )
twiddle [ nPk ] keep factorial / ;
: permutation ( n seq -- seq )
- tuck permutation-indices reorder ;
+ tuck permutation-indices nths ;
: all-permutations ( seq -- seq )
[
-Reginald Ford
\ No newline at end of file
+Reginald Ford
+Eduardo Cavazos
\ No newline at end of file
-USING: help.markup help.syntax ;
-
+USING: help.markup help.syntax math.functions ;
IN: math.derivatives
HELP: derivative ( x function -- m )
-{ $values { "x" "the x-position on the function" } { "function" "a differentiable function" } }
-{ $description "Finds the slope of the tangent line at the given x-position on the given function." } ;
+{ $values { "x" "a position on the function" } { "function" "a differentiable function" } }
+{ $description
+ "Approximates the slope of the tangent line by using Ridders' "
+ "method of computing derivatives, from the chapter \"Accurate computation "
+ "of F'(x) and F'(x)F''(x)\", from \"Advances in Engineering Software, Vol. 4, pp. 75-76 ."
+}
+{ $examples
+ { $example
+ "USING: math.derivatives prettyprint ;"
+ "[ sq ] 4 derivative ."
+ "8"
+ }
+ { $notes
+ "For applied scientists, you may play with the settings "
+ "in the source file to achieve arbitrary accuracy. "
+ }
+} ;
+
+HELP: (derivative) ( x function h err -- m )
+{ $values
+ { "x" "a position on the function" }
+ { "function" "a differentiable function" }
+ {
+ "h" "distance between the points of the first secant line used for "
+ "approximation of the tangent. This distance will be divided "
+ "constantly, by " { $link con } ". See " { $link init-hh }
+ " for the code which enforces this. H should be .001 to .5 -- too "
+ "small can cause bad convergence. Also, h should be small enough "
+ "to give the correct sgn(f'(x)). In other words, if you're expecting "
+ "a positive derivative, make h small enough to give the same "
+ "when plugged into the academic limit definition of a derivative. "
+ "See " { $link update-hh } " for the code which performs this task."
+ }
+ {
+ "err" "maximum tolerance of increase in error. For example, if this "
+ "is set to 2.0, the program will terminate with its nearest answer "
+ "when the error multiplies by 2. See " { $link check-safe } " for "
+ "the enforcing code."
+ }
+}
+{ $description
+ "Approximates the slope of the tangent line by using Ridders' "
+ "method of computing derivatives, from the chapter \"Accurate computation "
+ "of F'(x) and F'(x)F''(x)\", from \"Advances in Engineering Software, "
+ "Vol. 4, pp. 75-76 ."
+}
+{ $examples
+ { $example
+ "USING: math.derivatives prettyprint ;"
+ "[ sq ] 4 derivative ."
+ "8"
+ }
+ { $notes
+ "For applied scientists, you may play with the settings "
+ "in the source file to achieve arbitrary accuracy. "
+ }
+} ;
+
+HELP: derivative-func ( function -- der )
+{ $values { "func" "a differentiable function" } { "der" "the derivative" } }
+{ $description
+ "Provides the derivative of the function. The implementation simply "
+ "attaches the " { $link derivative } " word to the end of the function."
+}
+{ $examples
+ { $example
+ "USING: math.derivatives prettyprint ;"
+ "60 deg>rad [ sin ] derivative-func call ."
+ "0.5000000000000173"
+ }
+ { $notes
+ "Without a heavy algebraic system, derivatives must be "
+ "approximated. With the current settings, there is a fair trade of "
+ "speed and accuracy; the first 12 digits "
+ "will always be correct with " { $link sin } " and " { $link cos }
+ ". The following code performs a minumum and maximum error test."
+ { $code
+ "USING: kernel math math.functions math.trig sequences sequences.lib ;"
+ "360"
+ "["
+ " deg>rad"
+ " [ [ sin ] derivative-func call ]"
+ " ! Note: the derivative of sin is cos"
+ " [ cos ]"
+ " bi - abs"
+ "] map minmax"
+
+ }
+ }
+} ;
-{ derivative-func } related-words
+ARTICLE: "derivatives" "The Derivative Toolkit"
+"A toolkit for computing the derivative of functions."
+{ $subsection derivative }
+{ $subsection derivative-func }
+{ $subsection (derivative) } ;
+ABOUT: "derivatives"
-! Copyright © 2008 Reginald Keith Ford II
-! Tool for computing the derivative of a function at a point
-USING: kernel math math.points math.function-tools ;
+
+USING: kernel continuations combinators sequences math
+ math.order math.ranges accessors float-arrays ;
+
IN: math.derivatives
-: small-amount ( -- n ) 1.0e-14 ;
-: some-more ( x -- y ) small-amount + ;
-: some-less ( x -- y ) small-amount - ;
-: derivative ( x function -- m ) [ [ some-more ] dip eval ] [ [ some-less ] dip eval ] 2bi slope ;
-: derivative-func ( function -- function ) [ derivative ] curry ;
\ No newline at end of file
+TUPLE: state x func h err i j errt fac hh ans a done ;
+
+: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable
+: ntab ( -- val ) 8 ;
+: con ( -- val ) 1.6 ;
+: con2 ( -- val ) con con * ;
+: big ( -- val ) largest-float ;
+: safe ( -- val ) 2.0 ;
+
+! Yes, this was ported from C code.
+: a[i][i] ( state -- elt ) [ i>> ] [ i>> ] [ a>> ] tri nth nth ;
+: a[j][i] ( state -- elt ) [ i>> ] [ j>> ] [ a>> ] tri nth nth ;
+: a[j-1][i] ( state -- elt ) [ i>> ] [ j>> 1 - ] [ a>> ] tri nth nth ;
+: a[j-1][i-1] ( state -- elt ) [ i>> 1 - ] [ j>> 1 - ] [ a>> ] tri nth nth ;
+: a[i-1][i-1] ( state -- elt ) [ i>> 1 - ] [ i>> 1 - ] [ a>> ] tri nth nth ;
+
+: check-h ( state -- state )
+ dup h>> 0 = [ "h must be nonzero in dfridr" throw ] when ;
+: init-a ( state -- state ) ntab [ ntab <float-array> ] replicate >>a ;
+: init-hh ( state -- state ) dup h>> >>hh ;
+: init-err ( state -- state ) big >>err ;
+: update-hh ( state -- state ) dup hh>> con / >>hh ;
+: reset-fac ( state -- state ) con2 >>fac ;
+: update-fac ( state -- state ) dup fac>> con2 * >>fac ;
+
+! If error is decreased, save the improved answer
+: error-decreased? ( state -- state ? ) [ ] [ errt>> ] [ err>> ] tri <= ;
+: save-improved-answer ( state -- state )
+ dup err>> >>errt
+ dup a[j][i] >>ans ;
+
+! If higher order is worse by a significant factor SAFE, then quit early.
+: check-safe ( state -- state )
+ dup
+ [ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ] [ err>> safe * ] bi >=
+ [ t >>done ]
+ when ;
+: x+hh ( state -- val ) [ x>> ] [ hh>> ] bi + ;
+: x-hh ( state -- val ) [ x>> ] [ hh>> ] bi - ;
+: limit-approx ( state -- val )
+ [
+ [ [ x+hh ] [ func>> ] bi call ]
+ [ [ x-hh ] [ func>> ] bi call ]
+ bi -
+ ]
+ [ hh>> 2.0 * ]
+ bi / ;
+: a[0][0]! ( state -- state )
+ { [ ] [ limit-approx ] [ drop 0 ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+: a[0][i]! ( state -- state )
+ { [ ] [ limit-approx ] [ i>> ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+: a[j-1][i]*fac ( state -- val ) [ a[j-1][i] ] [ fac>> ] bi * ;
+: new-a[j][i] ( state -- val )
+ [ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ]
+ [ fac>> 1.0 - ]
+ bi / ;
+: a[j][i]! ( state -- state )
+ { [ ] [ new-a[j][i] ] [ i>> ] [ j>> ] [ a>> ] } cleave nth set-nth ;
+
+: update-errt ( state -- state )
+ dup
+ [ [ a[j][i] ] [ a[j-1][i] ] bi - abs ]
+ [ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ]
+ bi max
+ >>errt ;
+
+: not-done? ( state -- state ? ) dup done>> not ;
+
+: derive ( state -- state )
+ init-a
+ check-h
+ init-hh
+ a[0][0]!
+ init-err
+ 1 ntab [a,b)
+ [
+ >>i
+ not-done?
+ [
+ update-hh
+ a[0][i]!
+ reset-fac
+ 1 over i>> [a,b]
+ [
+ >>j
+ a[j][i]!
+ update-fac
+ update-errt
+ error-decreased? [ save-improved-answer ] when
+ ]
+ each
+ check-safe
+ ]
+ when
+ ]
+ each ;
+
+: derivative-state ( x func h err -- state )
+ state new
+ swap >>err
+ swap >>h
+ swap >>func
+ swap >>x ;
+
+! For scientists:
+! h should be .001 to .5 -- too small can cause bad convergence,
+! h should be small enough to give the correct sgn(f'(x))
+! err is the max tolerance of gain in error for a single iteration-
+: (derivative) ( x func h err -- ans error )
+ derivative-state
+ derive
+ [ ans>> ]
+ [ errt>> ]
+ bi ;
+
+: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ;
+: derivative-func ( func -- der ) [ derivative ] curry ;
\ No newline at end of file
USING: kernel math arrays sequences sequences.lib ;
IN: math.function-tools
-: difference-func ( func func -- func ) [ bi - ] 2curry ;
-: eval ( x func -- pt ) dupd call 2array ;
-: eval-inverse ( y func -- pt ) dupd call swap 2array ;
-: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ;
+: difference-func ( func func -- func ) [ bi - ] 2curry ; inline
+: eval ( x func -- pt ) dupd call 2array ; inline
+: eval-inverse ( y func -- pt ) dupd call swap 2array ; inline
+: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ; inline
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors hashtables kernel math state-tables vars vectors ;
+IN: regexp2.backend
+
+TUPLE: regexp
+ raw
+ { stack vector }
+ parse-tree
+ nfa-table
+ dfa-table
+ minimized-table
+ { state integer }
+ { new-states vector }
+ { visited-states hashtable } ;
+
+: reset-regexp ( regexp -- regexp )
+ 0 >>state
+ V{ } clone >>stack
+ V{ } clone >>new-states
+ H{ } clone >>visited-states ;
+
+SYMBOL: current-regexp
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math math.order symbols regexp2.parser
+words regexp2.utils unicode.categories combinators.short-circuit ;
+IN: regexp2.classes
+
+GENERIC: class-member? ( obj class -- ? )
+
+M: word class-member? ( obj class -- ? ) 2drop f ;
+M: integer class-member? ( obj class -- ? ) 2drop f ;
+
+M: character-class-range class-member? ( obj class -- ? )
+ [ from>> ] [ to>> ] bi between? ;
+
+M: any-char class-member? ( obj class -- ? )
+ 2drop t ;
+
+M: letter-class class-member? ( obj class -- ? )
+ drop letter? ;
+
+M: LETTER-class class-member? ( obj class -- ? )
+ drop LETTER? ;
+
+M: ascii-class class-member? ( obj class -- ? )
+ drop ascii? ;
+
+M: digit-class class-member? ( obj class -- ? )
+ drop digit? ;
+
+M: alpha-class class-member? ( obj class -- ? )
+ drop alpha? ;
+
+M: punctuation-class class-member? ( obj class -- ? )
+ drop punct? ;
+
+M: java-printable-class class-member? ( obj class -- ? )
+ drop java-printable? ;
+
+M: non-newline-blank-class class-member? ( obj class -- ? )
+ drop { [ blank? ] [ CHAR: \n = not ] } 1&& ;
+
+M: control-character-class class-member? ( obj class -- ? )
+ drop control-char? ;
+
+M: hex-digit-class class-member? ( obj class -- ? )
+ drop hex-digit? ;
+
+M: java-blank-class class-member? ( obj class -- ? )
+ drop java-blank? ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators fry kernel locals
+math math.order regexp2.nfa regexp2.transition-tables sequences
+sets sorting vectors regexp2.utils sequences.lib ;
+USING: io prettyprint threads ;
+IN: regexp2.dfa
+
+: find-delta ( states transition regexp -- new-states )
+ nfa-table>> transitions>>
+ rot [ swap at at ] with with map sift concat prune ;
+
+: (find-epsilon-closure) ( states regexp -- new-states )
+ eps swap find-delta ;
+
+: find-epsilon-closure ( states regexp -- new-states )
+ '[ dup , (find-epsilon-closure) union ] [ length ] while-changes
+ natural-sort ;
+
+: find-closure ( states transition regexp -- new-states )
+ [ find-delta ] 2keep nip find-epsilon-closure ;
+
+: find-start-state ( regexp -- state )
+ [ nfa-table>> start-state>> 1vector ] keep find-epsilon-closure ;
+
+: find-transitions ( seq1 regexp -- seq2 )
+ nfa-table>> transitions>>
+ [ at keys ] curry map concat eps swap remove ;
+
+: add-todo-state ( state regexp -- )
+ 2dup visited-states>> key? [
+ 2drop
+ ] [
+ [ visited-states>> conjoin ]
+ [ new-states>> push ] 2bi
+ ] if ;
+
+: new-transitions ( regexp -- )
+ dup new-states>> [
+ drop
+ ] [
+ dupd pop dup pick find-transitions rot
+ [
+ [ [ find-closure ] 2keep nip dupd add-todo-state ] 3keep
+ >r swapd transition boa r> dfa-table>> add-transition
+ ] curry with each
+ new-transitions
+ ] if-empty ;
+
+: states ( hashtable -- array )
+ [ keys ]
+ [ values [ values concat ] map concat append ] bi ;
+
+: set-final-states ( regexp -- )
+ dup
+ [ nfa-table>> final-states>> keys ]
+ [ dfa-table>> transitions>> states ] bi
+ [ intersect empty? not ] with filter
+
+ swap dfa-table>> final-states>>
+ [ conjoin ] curry each ;
+
+: set-initial-state ( regexp -- )
+ dup
+ [ dfa-table>> ] [ find-start-state ] bi
+ [ >>start-state drop ] keep
+ 1vector >>new-states drop ;
+
+: construct-dfa ( regexp -- )
+ [ set-initial-state ] [ new-transitions ] [ set-final-states ] tri ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs grouping kernel regexp2.backend
+locals math namespaces regexp2.parser sequences state-tables fry
+quotations math.order math.ranges vectors unicode.categories
+regexp2.utils regexp2.transition-tables words sequences.lib ;
+IN: regexp2.nfa
+
+SYMBOL: negation-mode
+: negated? ( -- ? ) negation-mode get 0 or odd? ;
+
+SINGLETON: eps
+
+: next-state ( regexp -- state )
+ [ state>> ] [ [ 1+ ] change-state drop ] bi ;
+
+: set-start-state ( regexp -- )
+ dup stack>> [
+ drop
+ ] [
+ [ nfa-table>> ] [ pop first ] bi* >>start-state drop
+ ] if-empty ;
+
+GENERIC: nfa-node ( node -- )
+
+:: add-simple-entry ( obj class -- )
+ [let* | regexp [ current-regexp get ]
+ s0 [ regexp next-state ]
+ s1 [ regexp next-state ]
+ stack [ regexp stack>> ]
+ table [ regexp nfa-table>> ] |
+ negated? [
+ s0 f obj class boa table add-transition
+ s0 s1 <default-transition> table add-transition
+ ] [
+ s0 s1 obj class boa table add-transition
+ ] if
+ s0 s1 2array stack push
+ t s1 table final-states>> set-at ] ;
+
+:: concatenate-nodes ( -- )
+ [let* | regexp [ current-regexp get ]
+ stack [ regexp stack>> ]
+ table [ regexp nfa-table>> ]
+ s2 [ stack peek first ]
+ s3 [ stack pop second ]
+ s0 [ stack peek first ]
+ s1 [ stack pop second ] |
+ s1 s2 eps <literal-transition> table add-transition
+ s1 table final-states>> delete-at
+ s0 s3 2array stack push ] ;
+
+:: alternate-nodes ( -- )
+ [let* | regexp [ current-regexp get ]
+ stack [ regexp stack>> ]
+ table [ regexp nfa-table>> ]
+ s2 [ stack peek first ]
+ s3 [ stack pop second ]
+ s0 [ stack peek first ]
+ s1 [ stack pop second ]
+ s4 [ regexp next-state ]
+ s5 [ regexp next-state ] |
+ s4 s0 eps <literal-transition> table add-transition
+ s4 s2 eps <literal-transition> table add-transition
+ s1 s5 eps <literal-transition> table add-transition
+ s3 s5 eps <literal-transition> table add-transition
+ s1 table final-states>> delete-at
+ s3 table final-states>> delete-at
+ t s5 table final-states>> set-at
+ s4 s5 2array stack push ] ;
+
+M: kleene-star nfa-node ( node -- )
+ term>> nfa-node
+ [let* | regexp [ current-regexp get ]
+ stack [ regexp stack>> ]
+ s0 [ stack peek first ]
+ s1 [ stack pop second ]
+ s2 [ regexp next-state ]
+ s3 [ regexp next-state ]
+ table [ regexp nfa-table>> ] |
+ s1 table final-states>> delete-at
+ t s3 table final-states>> set-at
+ s1 s0 eps <literal-transition> table add-transition
+ s2 s0 eps <literal-transition> table add-transition
+ s2 s3 eps <literal-transition> table add-transition
+ s1 s3 eps <literal-transition> table add-transition
+ s2 s3 2array stack push ] ;
+
+M: concatenation nfa-node ( node -- )
+ seq>>
+ [ [ nfa-node ] each ]
+ [ length 1- [ concatenate-nodes ] times ] bi ;
+
+M: alternation nfa-node ( node -- )
+ seq>>
+ [ [ nfa-node ] each ]
+ [ length 1- [ alternate-nodes ] times ] bi ;
+
+M: constant nfa-node ( node -- )
+ char>> literal-transition add-simple-entry ;
+
+M: epsilon nfa-node ( node -- )
+ drop eps literal-transition add-simple-entry ;
+
+M: word nfa-node ( node -- )
+ class-transition add-simple-entry ;
+
+M: character-class-range nfa-node ( node -- )
+ class-transition add-simple-entry ;
+
+M: capture-group nfa-node ( node -- )
+ term>> nfa-node ;
+
+M: negation nfa-node ( node -- )
+ negation-mode inc
+ term>> nfa-node
+ negation-mode dec ;
+
+: construct-nfa ( regexp -- )
+ [
+ reset-regexp
+ negation-mode off
+ [ current-regexp set ]
+ [ parse-tree>> nfa-node ]
+ [ set-start-state ] tri
+ ] with-scope ;
--- /dev/null
+USING: kernel tools.test regexp2.backend regexp2 ;
+IN: regexp2.parser
+
+: test-regexp ( string -- )
+ default-regexp parse-regexp ;
+
+: test-regexp2 ( string -- regexp )
+ default-regexp dup parse-regexp ;
+
+[ "(" ] [ unmatched-parentheses? ] must-fail-with
+
+[ ] [ "a|b" test-regexp ] unit-test
+[ ] [ "a.b" test-regexp ] unit-test
+[ ] [ "a|b|c" test-regexp ] unit-test
+[ ] [ "abc|b" test-regexp ] unit-test
+[ ] [ "a|bcd" test-regexp ] unit-test
+[ ] [ "a|(b)" test-regexp ] unit-test
+[ ] [ "(a)|b" test-regexp ] unit-test
+[ ] [ "(a|b)" test-regexp ] unit-test
+[ ] [ "((a)|(b))" test-regexp ] unit-test
+
+[ ] [ "(?:a)" test-regexp ] unit-test
+[ ] [ "(?i:a)" test-regexp ] unit-test
+[ ] [ "(?-i:a)" test-regexp ] unit-test
+[ "(?z:a)" test-regexp ] [ bad-option? ] must-fail-with
+[ "(?-z:a)" test-regexp ] [ bad-option? ] must-fail-with
+
+[ ] [ "(?=a)" test-regexp ] unit-test
+
+[ ] [ "[abc]" test-regexp ] unit-test
+[ ] [ "[a-c]" test-regexp ] unit-test
+[ ] [ "[^a-c]" test-regexp ] unit-test
+[ "[^]" test-regexp ] must-fail
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators io io.streams.string
+kernel math math.parser multi-methods namespaces qualified
+quotations sequences sequences.lib splitting symbols vectors
+dlists math.order combinators.lib unicode.categories
+sequences.lib regexp2.backend regexp2.utils ;
+IN: regexp2.parser
+
+FROM: math.ranges => [a,b] ;
+
+MIXIN: node
+TUPLE: concatenation seq ; INSTANCE: concatenation node
+TUPLE: alternation seq ; INSTANCE: alternation node
+TUPLE: kleene-star term ; INSTANCE: kleene-star node
+TUPLE: question term ; INSTANCE: question node
+TUPLE: negation term ; INSTANCE: negation node
+TUPLE: constant char ; INSTANCE: constant node
+TUPLE: range from to ; INSTANCE: range node
+TUPLE: lookahead term ; INSTANCE: lookahead node
+TUPLE: lookbehind term ; INSTANCE: lookbehind node
+TUPLE: capture-group term ; INSTANCE: capture-group node
+TUPLE: non-capture-group term ; INSTANCE: non-capture-group node
+TUPLE: independent-group term ; INSTANCE: independent-group node
+TUPLE: character-class-range from to ; INSTANCE: character-class-range node
+SINGLETON: epsilon INSTANCE: epsilon node
+SINGLETON: any-char INSTANCE: any-char node
+SINGLETON: front-anchor INSTANCE: front-anchor node
+SINGLETON: back-anchor INSTANCE: back-anchor node
+
+TUPLE: option-on option ; INSTANCE: option-on node
+TUPLE: option-off option ; INSTANCE: option-off node
+SINGLETONS: unix-lines dotall multiline comments case-insensitive unicode-case ;
+MIXIN: regexp-option
+INSTANCE: unix-lines regexp-option
+INSTANCE: dotall regexp-option
+INSTANCE: multiline regexp-option
+INSTANCE: comments regexp-option
+INSTANCE: case-insensitive regexp-option
+INSTANCE: unicode-case regexp-option
+
+SINGLETONS: letter-class LETTER-class Letter-class digit-class
+alpha-class non-newline-blank-class
+ascii-class punctuation-class java-printable-class blank-class
+control-character-class hex-digit-class java-blank-class c-identifier-class ;
+
+SINGLETONS: beginning-of-group end-of-group
+beginning-of-character-class end-of-character-class
+left-parenthesis pipe caret dash ;
+
+: <constant> ( obj -- constant ) constant boa ;
+: <negation> ( obj -- negation ) negation boa ;
+: <concatenation> ( seq -- concatenation ) >vector concatenation boa ;
+: <alternation> ( seq -- alternation ) >vector alternation boa ;
+: <capture-group> ( obj -- capture-group ) capture-group boa ;
+: <kleene-star> ( obj -- kleene-star ) kleene-star boa ;
+
+: first|concatenation ( seq -- first/concatenation )
+ dup length 1 = [ first ] [ <concatenation> ] if ;
+
+: first|alternation ( seq -- first/alternation )
+ dup length 1 = [ first ] [ <alternation> ] if ;
+
+ERROR: unmatched-parentheses ;
+
+: make-positive-lookahead ( string -- )
+ lookahead boa push-stack ;
+
+: make-negative-lookahead ( string -- )
+ <negation> lookahead boa push-stack ;
+
+: make-independent-group ( string -- )
+ #! no backtracking
+ independent-group boa push-stack ;
+
+: make-positive-lookbehind ( string -- )
+ lookbehind boa push-stack ;
+
+: make-negative-lookbehind ( string -- )
+ <negation> lookbehind boa push-stack ;
+
+DEFER: nested-parse-regexp
+: make-non-capturing-group ( string -- )
+ non-capture-group boa push-stack ;
+
+ERROR: bad-option ch ;
+
+: option ( ch -- singleton )
+ {
+ { CHAR: i [ case-insensitive ] }
+ { CHAR: d [ unix-lines ] }
+ { CHAR: m [ multiline ] }
+ { CHAR: s [ dotall ] }
+ { CHAR: u [ unicode-case ] }
+ { CHAR: x [ comments ] }
+ [ bad-option ]
+ } case ;
+
+: option-on ( ch -- ) option \ option-on boa push-stack ;
+: option-off ( ch -- ) option \ option-off boa push-stack ;
+: toggle-option ( ch ? -- ) [ option-on ] [ option-off ] if ;
+: (parse-options) ( string ? -- ) [ toggle-option ] curry each ;
+
+: parse-options ( string -- )
+ "-" split1 [ t (parse-options) ] [ f (parse-options) ] bi* ;
+
+DEFER: (parse-regexp)
+: parse-special-group-options ( options -- )
+ beginning-of-group push-stack
+ parse-options (parse-regexp) pop-stack make-non-capturing-group ;
+
+ERROR: bad-special-group string ;
+
+: (parse-special-group) ( -- )
+ read1 {
+ { [ dup CHAR: : = ]
+ [ drop nested-parse-regexp pop-stack make-non-capturing-group ] }
+ { [ dup CHAR: = = ]
+ [ drop nested-parse-regexp pop-stack make-positive-lookahead ] }
+ { [ dup CHAR: = = ]
+ [ drop nested-parse-regexp pop-stack make-negative-lookahead ] }
+ { [ dup CHAR: > = ]
+ [ drop nested-parse-regexp pop-stack make-independent-group ] }
+ { [ dup CHAR: < = peek1 CHAR: = = and ]
+ [ drop read1 drop nested-parse-regexp pop-stack make-positive-lookbehind ] }
+ { [ dup CHAR: < = peek1 CHAR: ! = and ]
+ [ drop read1 drop nested-parse-regexp pop-stack make-negative-lookbehind ] }
+ [
+ ":" read-until [ bad-special-group ] unless
+ swap prefix parse-special-group-options
+ ]
+ } cond ;
+
+: handle-left-parenthesis ( -- )
+ peek1 CHAR: ? =
+ [ read1 drop (parse-special-group) ]
+ [ nested-parse-regexp ] if ;
+
+: handle-dot ( -- ) any-char push-stack ;
+: handle-pipe ( -- ) pipe push-stack ;
+: handle-star ( -- ) stack pop <kleene-star> push-stack ;
+: handle-question ( -- )
+ stack pop epsilon 2array <alternation> push-stack ;
+: handle-plus ( -- )
+ stack pop dup <kleene-star> 2array <concatenation> push-stack ;
+
+ERROR: unmatched-brace ;
+: parse-repetition ( -- start finish ? )
+ "}" read-until [ unmatched-brace ] unless
+ [ "," split1 [ string>number ] bi@ ]
+ [ CHAR: , swap index >boolean ] bi ;
+
+: replicate/concatenate ( n obj -- obj' )
+ over zero? [ 2drop epsilon ]
+ [ <repetition> first|concatenation ] if ;
+
+: exactly-n ( n -- )
+ stack pop replicate/concatenate push-stack ;
+
+: at-least-n ( n -- )
+ stack pop
+ [ replicate/concatenate ] keep
+ <kleene-star> 2array <concatenation> push-stack ;
+
+: at-most-n ( n -- )
+ 1+
+ stack pop
+ [ replicate/concatenate ] curry map <alternation> push-stack ;
+
+: from-m-to-n ( m n -- )
+ [a,b]
+ stack pop
+ [ replicate/concatenate ] curry map
+ <alternation> push-stack ;
+
+ERROR: invalid-range a b ;
+
+: handle-left-brace ( -- )
+ parse-repetition
+ >r 2dup [ [ 0 < [ invalid-range ] when ] when* ] bi@ r>
+ [
+ 2dup and [ from-m-to-n ]
+ [ [ nip at-most-n ] [ at-least-n ] if* ] if
+ ] [ drop 0 max exactly-n ] if ;
+
+: handle-front-anchor ( -- ) front-anchor push-stack ;
+: handle-back-anchor ( -- ) back-anchor push-stack ;
+
+ERROR: bad-character-class obj ;
+ERROR: expected-posix-class ;
+
+: parse-posix-class ( -- obj )
+ read1 CHAR: { = [ expected-posix-class ] unless
+ "}" read-until [ bad-character-class ] unless
+ {
+ { "Lower" [ letter-class ] }
+ { "Upper" [ LETTER-class ] }
+ { "ASCII" [ ascii-class ] }
+ { "Alpha" [ Letter-class ] }
+ { "Digit" [ digit-class ] }
+ { "Alnum" [ alpha-class ] }
+ { "Punct" [ punctuation-class ] }
+ { "Graph" [ java-printable-class ] }
+ { "Print" [ java-printable-class ] }
+ { "Blank" [ non-newline-blank-class ] }
+ { "Cntrl" [ control-character-class ] }
+ { "XDigit" [ hex-digit-class ] }
+ { "Space" [ java-blank-class ] }
+ ! TODO: unicode-character-class, fallthrough in unicode is bad-char-clss
+ [ bad-character-class ]
+ } case ;
+
+: parse-octal ( -- n ) 3 read oct> check-octal ;
+: parse-short-hex ( -- n ) 2 read hex> check-hex ;
+: parse-long-hex ( -- n ) 6 read hex> check-hex ;
+: parse-control-character ( -- n ) read1 ;
+
+ERROR: bad-escaped-literals seq ;
+: parse-escaped-literals ( -- obj )
+ "\\E" read-until [ bad-escaped-literals ] unless
+ read1 drop
+ [ epsilon ] [
+ [ <constant> ] V{ } map-as
+ first|concatenation
+ ] if-empty ;
+
+: parse-escaped ( -- obj )
+ read1
+ {
+ { CHAR: \ [ CHAR: \ <constant> ] }
+ { CHAR: . [ CHAR: . <constant> ] }
+ { CHAR: t [ CHAR: \t <constant> ] }
+ { CHAR: n [ CHAR: \n <constant> ] }
+ { CHAR: r [ CHAR: \r <constant> ] }
+ { CHAR: f [ HEX: c <constant> ] }
+ { CHAR: a [ HEX: 7 <constant> ] }
+ { CHAR: e [ HEX: 1b <constant> ] }
+
+ { CHAR: d [ digit-class ] }
+ { CHAR: D [ digit-class <negation> ] }
+ { CHAR: s [ java-blank-class ] }
+ { CHAR: S [ java-blank-class <negation> ] }
+ { CHAR: w [ c-identifier-class ] }
+ { CHAR: W [ c-identifier-class <negation> ] }
+
+ { CHAR: p [ parse-posix-class ] }
+ { CHAR: P [ parse-posix-class <negation> ] }
+ { CHAR: x [ parse-short-hex <constant> ] }
+ { CHAR: u [ parse-long-hex <constant> ] }
+ { CHAR: 0 [ parse-octal <constant> ] }
+ { CHAR: c [ parse-control-character ] }
+
+ { CHAR: Q [ parse-escaped-literals ] }
+ } case ;
+
+: handle-escape ( -- ) parse-escaped push-stack ;
+
+: handle-dash ( vector -- vector' )
+ H{ { dash CHAR: - } } substitute ;
+
+: character-class>alternation ( seq -- alternation )
+ [ dup number? [ <constant> ] when ] map first|alternation ;
+
+: handle-caret ( vector -- vector' )
+ dup [ length 2 >= ] [ first caret eq? ] bi and [
+ rest-slice character-class>alternation <negation>
+ ] [
+ character-class>alternation
+ ] if ;
+
+: make-character-class ( -- character-class )
+ [ beginning-of-character-class swap cut-stack ] change-whole-stack
+ handle-dash handle-caret ;
+
+: apply-dash ( -- )
+ stack [ pop3 nip character-class-range boa ] keep push ;
+
+: apply-dash? ( -- ? )
+ stack dup length 3 >=
+ [ [ length 2 - ] keep nth dash eq? ] [ drop f ] if ;
+
+ERROR: empty-negated-character-class ;
+DEFER: handle-left-bracket
+: (parse-character-class) ( -- )
+ read1 [ empty-negated-character-class ] unless* {
+ { CHAR: [ [ handle-left-bracket t ] }
+ { CHAR: ] [ make-character-class push-stack f ] }
+ { CHAR: - [ dash push-stack t ] }
+ { CHAR: \ [ parse-escaped push-stack t ] }
+ [ push-stack apply-dash? [ apply-dash ] when t ]
+ } case
+ [ (parse-character-class) ] when ;
+
+: parse-character-class-second ( -- )
+ read1 {
+ { CHAR: [ [ CHAR: [ <constant> push-stack ] }
+ { CHAR: ] [ CHAR: ] <constant> push-stack ] }
+ { CHAR: - [ CHAR: - <constant> push-stack ] }
+ [ push1 ]
+ } case ;
+
+: parse-character-class-first ( -- )
+ read1 {
+ { CHAR: ^ [ caret push-stack parse-character-class-second ] }
+ { CHAR: [ [ CHAR: [ <constant> push-stack ] }
+ { CHAR: ] [ CHAR: ] <constant> push-stack ] }
+ { CHAR: - [ CHAR: - <constant> push-stack ] }
+ [ push1 ]
+ } case ;
+
+: handle-left-bracket ( -- )
+ beginning-of-character-class push-stack
+ parse-character-class-first (parse-character-class) ;
+
+ERROR: empty-regexp ;
+: finish-regexp-parse ( stack -- obj )
+ dup length {
+ { 0 [ empty-regexp ] }
+ { 1 [ first ] }
+ [
+ drop { pipe } split
+ [ first|concatenation ] map first|alternation
+ ]
+ } case ;
+
+: handle-right-parenthesis ( -- )
+ stack beginning-of-group over last-index cut rest
+ [ current-regexp get swap >>stack drop ]
+ [ finish-regexp-parse <capture-group> push-stack ] bi* ;
+
+: nested-parse-regexp ( -- )
+ beginning-of-group push-stack (parse-regexp) ;
+
+: ((parse-regexp)) ( token -- )
+ {
+ { CHAR: . [ handle-dot ] }
+ { CHAR: ( [ handle-left-parenthesis ] }
+ { CHAR: ) [ handle-right-parenthesis ] }
+ { CHAR: | [ handle-pipe ] }
+ { CHAR: ? [ handle-question ] }
+ { CHAR: * [ handle-star ] }
+ { CHAR: + [ handle-plus ] }
+ { CHAR: { [ handle-left-brace ] }
+ { CHAR: [ [ handle-left-bracket ] }
+ { CHAR: ^ [ handle-front-anchor ] }
+ { CHAR: $ [ handle-back-anchor ] }
+ { CHAR: \ [ handle-escape ] }
+ [ <constant> push-stack ]
+ } case ;
+
+: (parse-regexp) ( -- )
+ read1 [ ((parse-regexp)) (parse-regexp) ] when* ;
+
+: parse-regexp ( regexp -- )
+ dup current-regexp [
+ raw>> [
+ <string-reader> [ (parse-regexp) ] with-input-stream
+ ] unless-empty
+ current-regexp get
+ stack finish-regexp-parse
+ >>parse-tree drop
+ ] with-variable ;
--- /dev/null
+USING: regexp2 tools.test kernel regexp2.traversal ;
+IN: regexp2-tests
+
+[ f ] [ "b" "a*" <regexp> matches? ] unit-test
+[ t ] [ "" "a*" <regexp> matches? ] unit-test
+[ t ] [ "a" "a*" <regexp> matches? ] unit-test
+[ t ] [ "aaaaaaa" "a*" <regexp> matches? ] unit-test
+[ f ] [ "ab" "a*" <regexp> matches? ] unit-test
+
+[ t ] [ "abc" "abc" <regexp> matches? ] unit-test
+[ t ] [ "a" "a|b|c" <regexp> matches? ] unit-test
+[ t ] [ "b" "a|b|c" <regexp> matches? ] unit-test
+[ t ] [ "c" "a|b|c" <regexp> matches? ] unit-test
+[ f ] [ "c" "d|e|f" <regexp> matches? ] unit-test
+
+[ f ] [ "aa" "a|b|c" <regexp> matches? ] unit-test
+[ f ] [ "bb" "a|b|c" <regexp> matches? ] unit-test
+[ f ] [ "cc" "a|b|c" <regexp> matches? ] unit-test
+[ f ] [ "cc" "d|e|f" <regexp> matches? ] unit-test
+
+[ f ] [ "" "a+" <regexp> matches? ] unit-test
+[ t ] [ "a" "a+" <regexp> matches? ] unit-test
+[ t ] [ "aa" "a+" <regexp> matches? ] unit-test
+
+[ t ] [ "" "a?" <regexp> matches? ] unit-test
+[ t ] [ "a" "a?" <regexp> matches? ] unit-test
+[ f ] [ "aa" "a?" <regexp> matches? ] unit-test
+
+[ f ] [ "" "." <regexp> matches? ] unit-test
+[ t ] [ "a" "." <regexp> matches? ] unit-test
+[ t ] [ "." "." <regexp> matches? ] unit-test
+! [ f ] [ "\n" "." <regexp> matches? ] unit-test
+
+[ f ] [ "" ".+" <regexp> matches? ] unit-test
+[ t ] [ "a" ".+" <regexp> matches? ] unit-test
+[ t ] [ "ab" ".+" <regexp> matches? ] unit-test
+
+
+[ t ] [ "" "a|b*|c+|d?" <regexp> matches? ] unit-test
+[ t ] [ "a" "a|b*|c+|d?" <regexp> matches? ] unit-test
+[ t ] [ "c" "a|b*|c+|d?" <regexp> matches? ] unit-test
+[ t ] [ "cc" "a|b*|c+|d?" <regexp> matches? ] unit-test
+[ f ] [ "ccd" "a|b*|c+|d?" <regexp> matches? ] unit-test
+[ t ] [ "d" "a|b*|c+|d?" <regexp> matches? ] unit-test
+
+[ t ] [ "foo" "foo|bar" <regexp> matches? ] unit-test
+[ t ] [ "bar" "foo|bar" <regexp> matches? ] unit-test
+[ f ] [ "foobar" "foo|bar" <regexp> matches? ] unit-test
+
+[ f ] [ "" "(a)" <regexp> matches? ] unit-test
+[ t ] [ "a" "(a)" <regexp> matches? ] unit-test
+[ f ] [ "aa" "(a)" <regexp> matches? ] unit-test
+[ t ] [ "aa" "(a*)" <regexp> matches? ] unit-test
+
+[ f ] [ "aababaaabbac" "(a|b)+" <regexp> matches? ] unit-test
+[ t ] [ "ababaaabba" "(a|b)+" <regexp> matches? ] unit-test
+
+[ f ] [ "" "a{1}" <regexp> matches? ] unit-test
+[ t ] [ "a" "a{1}" <regexp> matches? ] unit-test
+[ f ] [ "aa" "a{1}" <regexp> matches? ] unit-test
+
+[ f ] [ "a" "a{2,}" <regexp> matches? ] unit-test
+[ t ] [ "aaa" "a{2,}" <regexp> matches? ] unit-test
+[ t ] [ "aaaa" "a{2,}" <regexp> matches? ] unit-test
+[ t ] [ "aaaaa" "a{2,}" <regexp> matches? ] unit-test
+
+[ t ] [ "" "a{,2}" <regexp> matches? ] unit-test
+[ t ] [ "a" "a{,2}" <regexp> matches? ] unit-test
+[ t ] [ "aa" "a{,2}" <regexp> matches? ] unit-test
+[ f ] [ "aaa" "a{,2}" <regexp> matches? ] unit-test
+[ f ] [ "aaaa" "a{,2}" <regexp> matches? ] unit-test
+[ f ] [ "aaaaa" "a{,2}" <regexp> matches? ] unit-test
+
+[ f ] [ "" "a{1,3}" <regexp> matches? ] unit-test
+[ t ] [ "a" "a{1,3}" <regexp> matches? ] unit-test
+[ t ] [ "aa" "a{1,3}" <regexp> matches? ] unit-test
+[ t ] [ "aaa" "a{1,3}" <regexp> matches? ] unit-test
+[ f ] [ "aaaa" "a{1,3}" <regexp> matches? ] unit-test
+
+[ f ] [ "" "[a]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[a]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[abc]" <regexp> matches? ] unit-test
+[ f ] [ "b" "[a]" <regexp> matches? ] unit-test
+[ f ] [ "d" "[abc]" <regexp> matches? ] unit-test
+[ t ] [ "ab" "[abc]{1,2}" <regexp> matches? ] unit-test
+[ f ] [ "abc" "[abc]{1,2}" <regexp> matches? ] unit-test
+
+[ f ] [ "" "[^a]" <regexp> matches? ] unit-test
+[ f ] [ "a" "[^a]" <regexp> matches? ] unit-test
+[ f ] [ "a" "[^abc]" <regexp> matches? ] unit-test
+[ t ] [ "b" "[^a]" <regexp> matches? ] unit-test
+[ t ] [ "d" "[^abc]" <regexp> matches? ] unit-test
+[ f ] [ "ab" "[^abc]{1,2}" <regexp> matches? ] unit-test
+[ f ] [ "abc" "[^abc]{1,2}" <regexp> matches? ] unit-test
+
+[ t ] [ "]" "[]]" <regexp> matches? ] unit-test
+[ f ] [ "]" "[^]]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[^]]" <regexp> matches? ] unit-test
+
+[ "^" "[^]" <regexp> matches? ] must-fail
+[ t ] [ "^" "[]^]" <regexp> matches? ] unit-test
+[ t ] [ "]" "[]^]" <regexp> matches? ] unit-test
+
+[ t ] [ "[" "[[]" <regexp> matches? ] unit-test
+[ f ] [ "^" "[^^]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[^^]" <regexp> matches? ] unit-test
+
+[ t ] [ "-" "[-]" <regexp> matches? ] unit-test
+[ f ] [ "a" "[-]" <regexp> matches? ] unit-test
+[ f ] [ "-" "[^-]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[^-]" <regexp> matches? ] unit-test
+
+[ t ] [ "-" "[-a]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[-a]" <regexp> matches? ] unit-test
+[ t ] [ "-" "[a-]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[a-]" <regexp> matches? ] unit-test
+[ f ] [ "b" "[a-]" <regexp> matches? ] unit-test
+[ f ] [ "-" "[^-]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[^-]" <regexp> matches? ] unit-test
+
+[ f ] [ "-" "[a-c]" <regexp> matches? ] unit-test
+[ t ] [ "-" "[^a-c]" <regexp> matches? ] unit-test
+[ t ] [ "b" "[a-c]" <regexp> matches? ] unit-test
+[ f ] [ "b" "[^a-c]" <regexp> matches? ] unit-test
+
+[ t ] [ "-" "[a-c-]" <regexp> matches? ] unit-test
+[ f ] [ "-" "[^a-c-]" <regexp> matches? ] unit-test
+
+[ t ] [ "\\" "[\\\\]" <regexp> matches? ] unit-test
+[ f ] [ "a" "[\\\\]" <regexp> matches? ] unit-test
+[ f ] [ "\\" "[^\\\\]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[^\\\\]" <regexp> matches? ] unit-test
+
+[ t ] [ "0" "[\\d]" <regexp> matches? ] unit-test
+[ f ] [ "a" "[\\d]" <regexp> matches? ] unit-test
+[ f ] [ "0" "[^\\d]" <regexp> matches? ] unit-test
+[ t ] [ "a" "[^\\d]" <regexp> matches? ] unit-test
+
+[ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" <regexp> matches? ] unit-test
+[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" <regexp> matches? ] unit-test
+[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" <regexp> matches? ] unit-test
+
+[ t ] [ "1000" "\\d{4,6}" <regexp> matches? ] unit-test
+[ t ] [ "1000" "[0-9]{4,6}" <regexp> matches? ] unit-test
+
+[ t ] [ "abc" "\\p{Lower}{3}" <regexp> matches? ] unit-test
+[ f ] [ "ABC" "\\p{Lower}{3}" <regexp> matches? ] unit-test
+[ t ] [ "ABC" "\\p{Upper}{3}" <regexp> matches? ] unit-test
+[ f ] [ "abc" "\\p{Upper}{3}" <regexp> matches? ] unit-test
+!
+[ f ] [ "abc" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
+[ t ] [ "ABC" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
+
+[ t ] [ "" "\\Q\\E" <regexp> matches? ] unit-test
+[ f ] [ "a" "\\Q\\E" <regexp> matches? ] unit-test
+[ t ] [ "|*+" "\\Q|*+\\E" <regexp> matches? ] unit-test
+[ f ] [ "abc" "\\Q|*+\\E" <regexp> matches? ] unit-test
+[ t ] [ "s" "\\Qs\\E" <regexp> matches? ] unit-test
+
+[ t ] [ "S" "\\0123" <regexp> matches? ] unit-test
+[ t ] [ "SXY" "\\0123XY" <regexp> matches? ] unit-test
+[ t ] [ "x" "\\x78" <regexp> matches? ] unit-test
+[ f ] [ "y" "\\x78" <regexp> matches? ] unit-test
+[ t ] [ "x" "\\u000078" <regexp> matches? ] unit-test
+[ f ] [ "y" "\\u000078" <regexp> matches? ] unit-test
+
+[ t ] [ "ab" "a+b" <regexp> matches? ] unit-test
+[ f ] [ "b" "a+b" <regexp> matches? ] unit-test
+[ t ] [ "aab" "a+b" <regexp> matches? ] unit-test
+[ f ] [ "abb" "a+b" <regexp> matches? ] unit-test
+
+[ t ] [ "abbbb" "ab*" <regexp> matches? ] unit-test
+[ t ] [ "a" "ab*" <regexp> matches? ] unit-test
+[ f ] [ "abab" "ab*" <regexp> matches? ] unit-test
+
+[ f ] [ "x" "\\." <regexp> matches? ] unit-test
+[ t ] [ "." "\\." <regexp> matches? ] unit-test
+
+[ t ] [ "aaaab" "a+ab" <regexp> matches? ] unit-test
+[ f ] [ "aaaxb" "a+ab" <regexp> matches? ] unit-test
+[ t ] [ "aaacb" "a+cb" <regexp> matches? ] unit-test
+[ f ] [ "aaaab" "a++ab" <regexp> matches? ] unit-test
+[ t ] [ "aaacb" "a++cb" <regexp> matches? ] unit-test
+
+[ 3 ] [ "aaacb" "a*" <regexp> match-head ] unit-test
+[ 1 ] [ "aaacb" "a+?" <regexp> match-head ] unit-test
+[ 2 ] [ "aaacb" "aa?" <regexp> match-head ] unit-test
+[ 1 ] [ "aaacb" "aa??" <regexp> match-head ] unit-test
+[ 3 ] [ "aacb" "aa?c" <regexp> match-head ] unit-test
+[ 3 ] [ "aacb" "aa??c" <regexp> match-head ] unit-test
+
+! [ t ] [ "aaa" "AAA" t <regexp> matches? ] unit-test
+! [ f ] [ "aax" "AAA" t <regexp> matches? ] unit-test
+! [ t ] [ "aaa" "A*" t <regexp> matches? ] unit-test
+! [ f ] [ "aaba" "A*" t <regexp> matches? ] unit-test
+! [ t ] [ "b" "[AB]" t <regexp> matches? ] unit-test
+! [ f ] [ "c" "[AB]" t <regexp> matches? ] unit-test
+! [ t ] [ "c" "[A-Z]" t <regexp> matches? ] unit-test
+! [ f ] [ "3" "[A-Z]" t <regexp> matches? ] unit-test
+
+[ ] [
+ "(0[lL]?|[1-9]\\d{0,9}(\\d{0,9}[lL])?|0[xX]\\p{XDigit}{1,8}(\\p{XDigit}{0,8}[lL])?|0[0-7]{1,11}([0-7]{0,11}[lL])?|([0-9]+\\.[0-9]*|\\.[0-9]+)([eE][+-]?[0-9]+)?[fFdD]?|[0-9]+([eE][+-]?[0-9]+[fFdD]?|([eE][+-]?[0-9]+)?[fFdD]))"
+ <regexp> drop
+] unit-test
+
+[ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
+[ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
+
+! [ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-head ] unit-test
+! [ f ] [ "foobxr" "foo(?=bar)" <regexp> match-head ] unit-test
+
+! [ f ] [ "foobxr" "foo\\z" <regexp> match-head ] unit-test
+! [ 3 ] [ "foo" "foo\\z" <regexp> match-head ] unit-test
+
+! [ 3 ] [ "foo bar" "foo\\b" <regexp> match-head ] unit-test
+! [ f ] [ "fooxbar" "foo\\b" <regexp> matches? ] unit-test
+! [ t ] [ "foo" "foo\\b" <regexp> matches? ] unit-test
+! [ t ] [ "foo bar" "foo\\b bar" <regexp> matches? ] unit-test
+! [ f ] [ "fooxbar" "foo\\bxbar" <regexp> matches? ] unit-test
+! [ f ] [ "foo" "foo\\bbar" <regexp> matches? ] unit-test
+
+! [ f ] [ "foo bar" "foo\\B" <regexp> matches? ] unit-test
+! [ 3 ] [ "fooxbar" "foo\\B" <regexp> match-head ] unit-test
+! [ t ] [ "foo" "foo\\B" <regexp> matches? ] unit-test
+! [ f ] [ "foo bar" "foo\\B bar" <regexp> matches? ] unit-test
+! [ t ] [ "fooxbar" "foo\\Bxbar" <regexp> matches? ] unit-test
+! [ f ] [ "foo" "foo\\Bbar" <regexp> matches? ] unit-test
+
+! [ t ] [ "s@f" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
+! [ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
+! [ t ] [ ".o" "\\.[a-z]" <regexp> matches? ] unit-test
+
+! Bug in parsing word
+! [ t ] [ "a" R' a' matches? ] unit-test
+
+! ((A)(B(C)))
+! 1. ((A)(B(C)))
+! 2. (A)
+! 3. (B(C))
+! 4. (C)
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators kernel regexp2.backend regexp2.utils
+regexp2.parser regexp2.nfa regexp2.dfa regexp2.traversal state-tables
+regexp2.transition-tables ;
+IN: regexp2
+
+: default-regexp ( string -- regexp )
+ regexp new
+ swap >>raw
+ <transition-table> >>nfa-table
+ <transition-table> >>dfa-table
+ <transition-table> >>minimized-table
+ reset-regexp ;
+
+: <regexp> ( string -- regexp )
+ default-regexp
+ {
+ [ parse-regexp ]
+ [ construct-nfa ]
+ [ construct-dfa ]
+ [ ]
+ } cleave ;
+
+: R! CHAR: ! <regexp> ; parsing
+: R" CHAR: " <regexp> ; parsing
+: R# CHAR: # <regexp> ; parsing
+: R' CHAR: ' <regexp> ; parsing
+: R( CHAR: ) <regexp> ; parsing
+: R/ CHAR: / <regexp> ; parsing
+: R@ CHAR: @ <regexp> ; parsing
+: R[ CHAR: ] <regexp> ; parsing
+: R` CHAR: ` <regexp> ; parsing
+: R{ CHAR: } <regexp> ; parsing
+: R| CHAR: | <regexp> ; parsing
--- /dev/null
+Regular expressions
--- /dev/null
+parsing
+text
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs fry hashtables kernel sequences
+vectors ;
+IN: regexp2.transition-tables
+
+: insert-at ( value key hash -- )
+ 2dup at* [
+ 2nip push
+ ] [
+ drop >r >r dup vector? [ 1vector ] unless r> r> set-at
+ ] if ;
+
+: ?insert-at ( value key hash/f -- hash )
+ [ H{ } clone ] unless* [ insert-at ] keep ;
+
+TUPLE: transition from to obj ;
+TUPLE: literal-transition < transition ;
+TUPLE: class-transition < transition ;
+TUPLE: default-transition < transition ;
+
+TUPLE: literal obj ;
+TUPLE: class obj ;
+TUPLE: default ;
+: <literal-transition> ( from to obj -- transition ) literal-transition boa ;
+: <class-transition> ( from to obj -- transition ) class-transition boa ;
+: <default-transition> ( from to -- transition ) t default-transition boa ;
+
+TUPLE: transition-table transitions
+ literals classes defaults
+ start-state final-states ;
+
+: <transition-table> ( -- transition-table )
+ transition-table new
+ H{ } clone >>transitions
+ H{ } clone >>final-states ;
+
+: set-transition ( transition hash -- )
+ >r [ to>> ] [ obj>> ] [ from>> ] tri r>
+ 2dup at* [ 2nip insert-at ]
+ [ drop >r >r H{ } clone [ insert-at ] keep r> r> set-at ] if ;
+
+: add-transition ( transition transition-table -- )
+ transitions>> set-transition ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators combinators.lib kernel
+math math.ranges quotations sequences regexp2.parser
+regexp2.classes combinators.short-circuit assocs.lib
+sequences.lib ;
+IN: regexp2.traversal
+
+TUPLE: dfa-traverser
+ dfa-table
+ last-state current-state
+ text
+ start-index current-index
+ matches ;
+
+: <dfa-traverser> ( text regexp -- match )
+ dfa-table>>
+ dfa-traverser new
+ swap [ start-state>> >>current-state ] keep
+ >>dfa-table
+ swap >>text
+ 0 >>start-index
+ 0 >>current-index
+ V{ } clone >>matches ;
+
+: final-state? ( dfa-traverser -- ? )
+ [ current-state>> ] [ dfa-table>> final-states>> ] bi
+ key? ;
+
+: text-finished? ( dfa-traverser -- ? )
+ [ current-index>> ] [ text>> length ] bi >= ;
+
+: save-final-state ( dfa-straverser -- )
+ [ current-index>> ] [ matches>> ] bi push ;
+
+: match-done? ( dfa-traverser -- ? )
+ dup final-state? [
+ dup save-final-state
+ ] when text-finished? ;
+
+: increment-state ( dfa-traverser state -- dfa-traverser )
+ >r [ 1+ ] change-current-index
+ dup current-state>> >>last-state r>
+ first >>current-state ;
+
+: match-failed ( dfa-traverser -- dfa-traverser )
+ V{ } clone >>matches ;
+
+: match-literal ( transition from-state table -- to-state/f )
+ transitions>> [ at ] [ 2drop f ] if-at ;
+
+: assoc-with ( param assoc quot -- assoc curry )
+ swapd [ [ -rot ] dip call ] 2curry ; inline
+
+: match-class ( transition from-state table -- to-state/f )
+ transitions>> at* [
+ [ drop class-member? ] assoc-with assoc-find [ nip ] [ drop ] if
+ ] [ drop ] if ;
+
+: match-default ( transition from-state table -- to-state/f )
+ [ nip ] dip transitions>>
+ [ t swap [ drop f ] unless-at ] [ drop f ] if-at ;
+
+: match-transition ( obj from-state dfa -- to-state/f )
+ { [ match-literal ] [ match-class ] [ match-default ] } 3|| ;
+
+: setup-match ( match -- obj state dfa-table )
+ { current-index>> text>> current-state>> dfa-table>> } get-slots
+ [ nth ] 2dip ;
+
+: do-match ( dfa-traverser -- dfa-traverser )
+ dup match-done? [
+ dup setup-match match-transition
+ [ increment-state do-match ] when*
+ ] unless ;
+
+: return-match ( dfa-traverser -- interval/f )
+ dup matches>>
+ [ drop f ]
+ [ [ start-index>> ] [ peek ] bi* 1 <range> ] if-empty ;
+
+: match ( string regexp -- pair )
+ <dfa-traverser> do-match return-match ;
+
+: matches? ( string regexp -- ? )
+ dupd match [ [ length ] [ range-length 1- ] bi* = ] [ drop f ] if* ;
+
+: match-head ( string regexp -- end ) match length>> 1- ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators.lib io kernel
+math math.order namespaces regexp2.backend sequences
+sequences.lib unicode.categories math.ranges fry
+combinators.short-circuit ;
+IN: regexp2.utils
+
+: (while-changes) ( obj quot pred pred-ret -- obj )
+ ! quot: ( obj -- obj' )
+ ! pred: ( obj -- <=> )
+ >r >r dup slip r> pick over call r> dupd =
+ [ 3drop ] [ (while-changes) ] if ; inline
+
+: while-changes ( obj quot pred -- obj' )
+ pick over call (while-changes) ; inline
+
+: last-state ( regexp -- range ) stack>> peek first2 [a,b] ;
+: push1 ( obj -- ) input-stream get stream>> push ;
+: peek1 ( -- obj ) input-stream get stream>> [ f ] [ peek ] if-empty ;
+: pop3 ( seq -- obj1 obj2 obj3 ) [ pop ] [ pop ] [ pop ] tri spin ;
+
+: stack ( -- obj ) current-regexp get stack>> ;
+: change-whole-stack ( quot -- )
+ current-regexp get
+ [ stack>> swap call ] keep (>>stack) ; inline
+: push-stack ( obj -- ) stack push ;
+: pop-stack ( -- obj ) stack pop ;
+: cut-out ( vector n -- vector' vector ) cut rest ;
+ERROR: cut-stack-error ;
+: cut-stack ( obj vector -- vector' vector )
+ tuck last-index [ cut-stack-error ] unless* cut-out swap ;
+
+ERROR: bad-octal number ;
+ERROR: bad-hex number ;
+: check-octal ( octal -- octal ) dup 255 > [ bad-octal ] when ;
+: check-hex ( hex -- hex ) dup number? [ bad-hex ] unless ;
+
+: ascii? ( n -- ? ) 0 HEX: 7f between? ;
+: octal-digit? ( n -- ? ) CHAR: 0 CHAR: 7 between? ;
+: decimal-digit? ( n -- ? ) CHAR: 0 CHAR: 9 between? ;
+
+: hex-digit? ( n -- ? )
+ [
+ [ decimal-digit? ]
+ [ CHAR: a CHAR: f between? ]
+ [ CHAR: A CHAR: F between? ]
+ ] 1|| ;
+
+: control-char? ( n -- ? )
+ [
+ [ 0 HEX: 1f between? ]
+ [ HEX: 7f = ]
+ ] 1|| ;
+
+: punct? ( n -- ? )
+ "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
+
+: c-identifier-char? ( ch -- ? )
+ [ [ alpha? ] [ CHAR: _ = ] ] 1|| ;
+
+: java-blank? ( n -- ? )
+ {
+ CHAR: \s CHAR: \t CHAR: \n
+ HEX: b HEX: 7 CHAR: \r
+ } member? ;
+
+: java-printable? ( n -- ? )
+ [ [ alpha? ] [ punct? ] ] 1|| ;
: insert-nth ( elt n seq -- seq' )
swap cut-slice [ swap 1array ] dip 3append ;
-: if-seq ( seq quot1 quot2 -- )
- [ f like ] 2dip if* ; inline
+: if-seq ( seq quot1 quot2 -- ) [ f like ] 2dip if* ; inline
+
+: if-empty ( seq quot1 quot2 -- ) swap if-seq ; inline
+
+: when-empty ( seq quot1 -- ) [ ] if-empty ; inline
+
+: unless-empty ( seq quot1 -- ) [ ] swap if-empty ; inline
-: if-empty ( seq quot1 quot2 -- )
- swap if-seq ; inline
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types assocs combinators destructors
+kernel math math.bitfields math.parser sequences summary system
+vocabs.loader ;
+IN: serial
+
+TUPLE: serial stream path baud
+ termios iflag oflag cflag lflag ;
+
+ERROR: invalid-baud baud ;
+M: invalid-baud summary ( invalid-baud -- string )
+ "Baud rate "
+ swap baud>> number>string
+ " not supported" 3append ;
+
+HOOK: lookup-baud os ( m -- n )
+HOOK: open-serial os ( serial -- serial' )
+M: serial dispose ( serial -- ) stream>> dispose ;
+
+{
+ { [ os unix? ] [ "serial.unix" ] }
+} cond require
--- /dev/null
+Serial port library
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel math.bitfields sequences system serial ;
+IN: serial.unix
+
+M: bsd lookup-baud ( m -- n )
+ dup {
+ 0 50 75 110 134 150 200 300 600 1200 1800 2400 4800
+ 7200 9600 14400 19200 28800 38400 57600 76800 115200
+ 230400 460800 921600
+ } member? [ invalid-baud ] unless ;
+
+: TCSANOW 0 ; inline
+: TCSADRAIN 1 ; inline
+: TCSAFLUSH 2 ; inline
+: TCSASOFT HEX: 10 ; inline
+
+: TCIFLUSH 1 ; inline
+: TCOFLUSH 2 ; inline
+: TCIOFLUSH 3 ; inline
+: TCOOFF 1 ; inline
+: TCOON 2 ; inline
+: TCIOFF 3 ; inline
+: TCION 4 ; inline
+
+! iflags
+: IGNBRK HEX: 00000001 ; inline
+: BRKINT HEX: 00000002 ; inline
+: IGNPAR HEX: 00000004 ; inline
+: PARMRK HEX: 00000008 ; inline
+: INPCK HEX: 00000010 ; inline
+: ISTRIP HEX: 00000020 ; inline
+: INLCR HEX: 00000040 ; inline
+: IGNCR HEX: 00000080 ; inline
+: ICRNL HEX: 00000100 ; inline
+: IXON HEX: 00000200 ; inline
+: IXOFF HEX: 00000400 ; inline
+: IXANY HEX: 00000800 ; inline
+: IMAXBEL HEX: 00002000 ; inline
+: IUTF8 HEX: 00004000 ; inline
+
+! oflags
+: OPOST HEX: 00000001 ; inline
+: ONLCR HEX: 00000002 ; inline
+: OXTABS HEX: 00000004 ; inline
+: ONOEOT HEX: 00000008 ; inline
+
+! cflags
+: CIGNORE HEX: 00000001 ; inline
+: CSIZE HEX: 00000300 ; inline
+: CS5 HEX: 00000000 ; inline
+: CS6 HEX: 00000100 ; inline
+: CS7 HEX: 00000200 ; inline
+: CS8 HEX: 00000300 ; inline
+: CSTOPB HEX: 00000400 ; inline
+: CREAD HEX: 00000800 ; inline
+: PARENB HEX: 00001000 ; inline
+: PARODD HEX: 00002000 ; inline
+: HUPCL HEX: 00004000 ; inline
+: CLOCAL HEX: 00008000 ; inline
+: CCTS_OFLOW HEX: 00010000 ; inline
+: CRTS_IFLOW HEX: 00020000 ; inline
+: CRTSCTS { CCTS_OFLOW CRTS_IFLOW } flags ; inline
+: CDTR_IFLOW HEX: 00040000 ; inline
+: CDSR_OFLOW HEX: 00080000 ; inline
+: CCAR_OFLOW HEX: 00100000 ; inline
+: MDMBUF HEX: 00100000 ; inline
+
+! lflags
+: ECHOKE HEX: 00000001 ; inline
+: ECHOE HEX: 00000002 ; inline
+: ECHOK HEX: 00000004 ; inline
+: ECHO HEX: 00000008 ; inline
+: ECHONL HEX: 00000010 ; inline
+: ECHOPRT HEX: 00000020 ; inline
+: ECHOCTL HEX: 00000040 ; inline
+: ISIG HEX: 00000080 ; inline
+: ICANON HEX: 00000100 ; inline
+: ALTWERASE HEX: 00000200 ; inline
+: IEXTEN HEX: 00000400 ; inline
+: EXTPROC HEX: 00000800 ; inline
+: TOSTOP HEX: 00400000 ; inline
+: FLUSHO HEX: 00800000 ; inline
+: NOKERNINFO HEX: 02000000 ; inline
+: PENDIN HEX: 20000000 ; inline
+: NOFLSH HEX: 80000000 ; inline
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs alien.syntax kernel serial system unix ;
+IN: serial.unix
+
+: TCSANOW 0 ; inline
+: TCSADRAIN 1 ; inline
+: TCSAFLUSH 2 ; inline
+
+: TCIFLUSH 0 ; inline
+: TCOFLUSH 1 ; inline
+: TCIOFLUSH 2 ; inline
+
+: TCOOFF 0 ; inline
+: TCOON 1 ; inline
+: TCIOFF 2 ; inline
+: TCION 3 ; inline
+
+! iflag
+: IGNBRK OCT: 0000001 ; inline
+: BRKINT OCT: 0000002 ; inline
+: IGNPAR OCT: 0000004 ; inline
+: PARMRK OCT: 0000010 ; inline
+: INPCK OCT: 0000020 ; inline
+: ISTRIP OCT: 0000040 ; inline
+: INLCR OCT: 0000100 ; inline
+: IGNCR OCT: 0000200 ; inline
+: ICRNL OCT: 0000400 ; inline
+: IUCLC OCT: 0001000 ; inline
+: IXON OCT: 0002000 ; inline
+: IXANY OCT: 0004000 ; inline
+: IXOFF OCT: 0010000 ; inline
+: IMAXBEL OCT: 0020000 ; inline
+: IUTF8 OCT: 0040000 ; inline
+
+! oflag
+: OPOST OCT: 0000001 ; inline
+: OLCUC OCT: 0000002 ; inline
+: ONLCR OCT: 0000004 ; inline
+: OCRNL OCT: 0000010 ; inline
+: ONOCR OCT: 0000020 ; inline
+: ONLRET OCT: 0000040 ; inline
+: OFILL OCT: 0000100 ; inline
+: OFDEL OCT: 0000200 ; inline
+: NLDLY OCT: 0000400 ; inline
+: NL0 OCT: 0000000 ; inline
+: NL1 OCT: 0000400 ; inline
+: CRDLY OCT: 0003000 ; inline
+: CR0 OCT: 0000000 ; inline
+: CR1 OCT: 0001000 ; inline
+: CR2 OCT: 0002000 ; inline
+: CR3 OCT: 0003000 ; inline
+: TABDLY OCT: 0014000 ; inline
+: TAB0 OCT: 0000000 ; inline
+: TAB1 OCT: 0004000 ; inline
+: TAB2 OCT: 0010000 ; inline
+: TAB3 OCT: 0014000 ; inline
+: BSDLY OCT: 0020000 ; inline
+: BS0 OCT: 0000000 ; inline
+: BS1 OCT: 0020000 ; inline
+: FFDLY OCT: 0100000 ; inline
+: FF0 OCT: 0000000 ; inline
+: FF1 OCT: 0100000 ; inline
+
+! cflags
+: CSIZE OCT: 0000060 ; inline
+: CS5 OCT: 0000000 ; inline
+: CS6 OCT: 0000020 ; inline
+: CS7 OCT: 0000040 ; inline
+: CS8 OCT: 0000060 ; inline
+: CSTOPB OCT: 0000100 ; inline
+: CREAD OCT: 0000200 ; inline
+: PARENB OCT: 0000400 ; inline
+: PARODD OCT: 0001000 ; inline
+: HUPCL OCT: 0002000 ; inline
+: CLOCAL OCT: 0004000 ; inline
+: CIBAUD OCT: 002003600000 ; inline
+: CRTSCTS OCT: 020000000000 ; inline
+
+! lflags
+: ISIG OCT: 0000001 ; inline
+: ICANON OCT: 0000002 ; inline
+: XCASE OCT: 0000004 ; inline
+: ECHO OCT: 0000010 ; inline
+: ECHOE OCT: 0000020 ; inline
+: ECHOK OCT: 0000040 ; inline
+: ECHONL OCT: 0000100 ; inline
+: NOFLSH OCT: 0000200 ; inline
+: TOSTOP OCT: 0000400 ; inline
+: ECHOCTL OCT: 0001000 ; inline
+: ECHOPRT OCT: 0002000 ; inline
+: ECHOKE OCT: 0004000 ; inline
+: FLUSHO OCT: 0010000 ; inline
+: PENDIN OCT: 0040000 ; inline
+: IEXTEN OCT: 0100000 ; inline
+
+M: linux lookup-baud ( n -- n )
+ dup H{
+ { 0 OCT: 0000000 }
+ { 50 OCT: 0000001 }
+ { 75 OCT: 0000002 }
+ { 110 OCT: 0000003 }
+ { 134 OCT: 0000004 }
+ { 150 OCT: 0000005 }
+ { 200 OCT: 0000006 }
+ { 300 OCT: 0000007 }
+ { 600 OCT: 0000010 }
+ { 1200 OCT: 0000011 }
+ { 1800 OCT: 0000012 }
+ { 2400 OCT: 0000013 }
+ { 4800 OCT: 0000014 }
+ { 9600 OCT: 0000015 }
+ { 19200 OCT: 0000016 }
+ { 38400 OCT: 0000017 }
+ { 57600 OCT: 0010001 }
+ { 115200 OCT: 0010002 }
+ { 230400 OCT: 0010003 }
+ { 460800 OCT: 0010004 }
+ { 500000 OCT: 0010005 }
+ { 576000 OCT: 0010006 }
+ { 921600 OCT: 0010007 }
+ { 1000000 OCT: 0010010 }
+ { 1152000 OCT: 0010011 }
+ { 1500000 OCT: 0010012 }
+ { 2000000 OCT: 0010013 }
+ { 2500000 OCT: 0010014 }
+ { 3000000 OCT: 0010015 }
+ { 3500000 OCT: 0010016 }
+ { 4000000 OCT: 0010017 }
+ } at* [ nip ] [ drop invalid-baud ] if ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel sequences system ;
+IN: serial.unix.termios
+
+: NCCS 20 ; inline
+
+TYPEDEF: uint tcflag_t
+TYPEDEF: uchar cc_t
+TYPEDEF: uint speed_t
+
+C-STRUCT: termios
+ { "tcflag_t" "iflag" } ! input mode flags
+ { "tcflag_t" "oflag" } ! output mode flags
+ { "tcflag_t" "cflag" } ! control mode flags
+ { "tcflag_t" "lflag" } ! local mode flags
+ { { "cc_t" NCCS } "cc" } ! control characters
+ { "speed_t" "ispeed" } ! input speed
+ { "speed_t" "ospeed" } ; ! output speed
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel system unix ;
+IN: serial.unix.termios
+
+: NCCS 32 ; inline
+
+TYPEDEF: uchar cc_t
+TYPEDEF: uint speed_t
+TYPEDEF: uint tcflag_t
+
+C-STRUCT: termios
+ { "tcflag_t" "iflag" } ! input mode flags
+ { "tcflag_t" "oflag" } ! output mode flags
+ { "tcflag_t" "cflag" } ! control mode flags
+ { "tcflag_t" "lflag" } ! local mode flags
+ { "cc_t" "line" } ! line discipline
+ { { "cc_t" NCCS } "cc" } ! control characters
+ { "speed_t" "ispeed" } ! input speed
+ { "speed_t" "ospeed" } ; ! output speed
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators system vocabs.loader ;
+IN: serial.unix.termios
+
+{
+ { [ os linux? ] [ "serial.unix.termios.linux" ] }
+ { [ os bsd? ] [ "serial.unix.termios.bsd" ] }
+} cond require
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math.bitfields serial serial.unix ;
+IN: serial.unix
+
+: serial-obj ( -- obj )
+ serial new
+ "/dev/ttyS0" >>path
+ 19200 >>baud
+ { IGNPAR ICRNL } flags >>iflag
+ { } flags >>oflag
+ { CS8 CLOCAL CREAD } flags >>cflag
+ { ICANON } flags >>lflag ;
+
+: serial-test ( -- serial )
+ serial-obj
+ open-serial
+ dup get-termios >>termios
+ dup configure-termios
+ dup tciflush
+ dup apply-termios ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.syntax combinators io.ports
+io.streams.duplex io.unix.backend system kernel math math.bitfields
+vocabs.loader unix serial serial.unix.termios ;
+IN: serial.unix
+
+<< {
+ { [ os linux? ] [ "serial.unix.linux" ] }
+ { [ os bsd? ] [ "serial.unix.bsd" ] }
+} cond require >>
+
+FUNCTION: speed_t cfgetispeed ( termios* t ) ;
+FUNCTION: speed_t cfgetospeed ( termios* t ) ;
+FUNCTION: int cfsetispeed ( termios* t, speed_t s ) ;
+FUNCTION: int cfsetospeed ( termios* t, speed_t s ) ;
+FUNCTION: int tcgetattr ( int i1, termios* t ) ;
+FUNCTION: int tcsetattr ( int i1, int i2, termios* t ) ;
+FUNCTION: int tcdrain ( int i1 ) ;
+FUNCTION: int tcflow ( int i1, int i2 ) ;
+FUNCTION: int tcflush ( int i1, int i2 ) ;
+FUNCTION: int tcsendbreak ( int i1, int i2 ) ;
+FUNCTION: void cfmakeraw ( termios* t ) ;
+FUNCTION: int cfsetspeed ( termios* t, speed_t s ) ;
+
+: fd>duplex-stream ( fd -- duplex-stream )
+ <fd> init-fd
+ [ <input-port> ] [ <output-port> ] bi <duplex-stream> ;
+
+: open-rw ( path -- fd ) O_RDWR file-mode open-file ;
+: <file-rw> ( path -- stream ) open-rw fd>duplex-stream ;
+
+M: unix open-serial ( serial -- serial' )
+ dup
+ path>> { O_RDWR O_NOCTTY O_NDELAY } flags file-mode open-file
+ fd>duplex-stream >>stream ;
+
+: serial-fd ( serial -- fd )
+ stream>> in>> handle>> fd>> ;
+
+: get-termios ( serial -- termios )
+ serial-fd
+ "termios" <c-object> [ tcgetattr io-error ] keep ;
+
+: configure-termios ( serial -- )
+ dup termios>>
+ {
+ [ [ iflag>> ] dip over [ set-termios-iflag ] [ 2drop ] if ]
+ [ [ oflag>> ] dip over [ set-termios-oflag ] [ 2drop ] if ]
+ [
+ [
+ [ cflag>> 0 or ] [ baud>> lookup-baud ] bi bitor
+ ] dip set-termios-cflag
+ ]
+ [ [ lflag>> ] dip over [ set-termios-lflag ] [ 2drop ] if ]
+ } 2cleave ;
+
+: tciflush ( serial -- )
+ serial-fd TCIFLUSH tcflush io-error ;
+
+: apply-termios ( serial -- )
+ [ serial-fd TCSANOW ]
+ [ termios>> ] bi tcsetattr io-error ;
-USING: arrays assocs kernel math math.intervals namespaces
-sequences combinators.lib money math.order ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs kernel math math.intervals
+namespaces sequences combinators.lib money math.order ;
IN: taxes
: monthly ( x -- y ) 12 / ;
: allowance ( -- x ) 3500 ; inline
-: calculate-w4-allowances ( w4 -- x )
- w4-allowances allowance * ;
+: calculate-w4-allowances ( w4 -- x ) allowances>> allowance * ;
! Withhold: FICA, Medicare, Federal (FICA is social security)
: fica-tax-rate ( -- x ) DECIMAL: .062 ; inline
! Base rate -- income over this rate is not taxed
-TUPLE: fica-base-unknown ;
+ERROR: fica-base-unknown ;
: fica-base-rate ( year -- x )
H{
{ 2008 102000 }
{ 2007 97500 }
- } at* [ T{ fica-base-unknown } throw ] unless ;
+ } at* [ fica-base-unknown ] unless ;
: fica-tax ( salary w4 -- x )
- w4-year fica-base-rate min fica-tax-rate * ;
+ year>> fica-base-rate min fica-tax-rate * ;
! Employer tax only, not withheld
: futa-tax-rate ( -- x ) DECIMAL: .062 ; inline
0 -rot [ tax-bracket ] each drop ;
: marriage-table ( w4 tax-table -- triples )
- swap w4-married?
- [ tax-table-married ] [ tax-table-single ] if ;
+ swap married?>> [ married>> ] [ single>> ] if ;
: federal-tax ( salary w4 tax-table -- n )
[ adjust-allowances ] 2keep marriage-table tax ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2006, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces opengl opengl.gl ;
-IN: ui.backend
-
-SYMBOL: ui-backend
-
-HOOK: do-events ui-backend ( -- )
-
-HOOK: set-title ui-backend ( string world -- )
-
-HOOK: set-fullscreen* ui-backend ( ? world -- )
-
-HOOK: fullscreen* ui-backend ( world -- ? )
-
-HOOK: (open-window) ui-backend ( world -- )
-
-HOOK: (close-window) ui-backend ( handle -- )
-
-HOOK: raise-window* ui-backend ( world -- )
-
-HOOK: select-gl-context ui-backend ( handle -- )
-
-HOOK: flush-gl-context ui-backend ( handle -- )
-
-HOOK: beep ui-backend ( -- )
-
-: with-gl-context ( handle quot -- )
- swap [ select-gl-context call ] keep
- glFlush flush-gl-context gl-error ; inline
+++ /dev/null
-UI backend hooks
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets ui.gestures help.markup help.syntax strings ;
-IN: ui.clipboards
-
-HELP: clipboard
-{ $var-description "Global variable holding the system clipboard. By convention, text should only be copied to the clipboard via an explicit user action, for example by pressing " { $snippet "C+c" } "." }
-{ $class-description "A mutable container for a single string implementing the " { $link "clipboard-protocol" } "." } ;
-
-HELP: paste-clipboard
-{ $values { "gadget" gadget } { "clipboard" "an object" } }
-{ $contract "Arranges for the contents of the clipboard to be inserted into the gadget at some point in the near future via a call to " { $link user-input } ". The gadget must be grafted." } ;
-
-HELP: copy-clipboard
-{ $values { "string" string } { "gadget" gadget } { "clipboard" "an object" } }
-{ $contract "Arranges for the string to be copied to the clipboard on behalf of the gadget. The gadget must be grafted." } ;
-
-HELP: selection
-{ $var-description "Global variable holding the system selection. By convention, text should be copied to the selection as soon as it is selected by the user." } ;
-
-ARTICLE: "clipboard-protocol" "Clipboard protocol"
-"Custom gadgets that wish to interact with the clipboard must use the following two generic words to read and write clipboard contents:"
-{ $subsection paste-clipboard }
-{ $subsection copy-clipboard }
-"UI backends can either implement the above two words in the case of an asynchronous clipboard model (for example, X11). If direct access to the clipboard is provided (Windows, Mac OS X), the following two generic words may be implemented instead:"
-{ $subsection clipboard-contents }
-{ $subsection set-clipboard-contents }
-"However, gadgets should not call these words, since they will fail if only the asynchronous method of clipboard access is supported by the backend in use."
-$nl
-"Access to two clipboards is provided:"
-{ $subsection clipboard }
-{ $subsection selection }
-"These variables may contain clipboard protocol implementations which transfer data to and from the native system clipboard. However an UI backend may leave one or both of these variables in their default state, which is a trivial clipboard implementation internal to the Factor UI." ;
-
-ABOUT: "clipboard-protocol"
+++ /dev/null
-! Copyright (C) 2006, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel ui.gadgets ui.gestures namespaces ;
-IN: ui.clipboards
-
-! Two text transfer buffers
-TUPLE: clipboard contents ;
-: <clipboard> ( -- clipboard ) "" clipboard boa ;
-
-GENERIC: paste-clipboard ( gadget clipboard -- )
-
-M: object paste-clipboard
- clipboard-contents dup [ swap user-input ] [ 2drop ] if ;
-
-GENERIC: copy-clipboard ( string gadget clipboard -- )
-
-M: object copy-clipboard nip set-clipboard-contents ;
-
-SYMBOL: clipboard
-SYMBOL: selection
-
-: gadget-copy ( gadget clipboard -- )
- over gadget-selection? [
- >r [ gadget-selection ] keep r> copy-clipboard
- ] [
- 2drop
- ] if ;
-
-: com-copy ( gadget -- ) clipboard get gadget-copy ;
-
-: com-copy-selection ( gadget -- ) selection get gadget-copy ;
+++ /dev/null
-Abstract clipboard support
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors math arrays cocoa cocoa.application
-command-line kernel memory namespaces cocoa.messages
-cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
-cocoa.windows cocoa.classes cocoa.application sequences system
-ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
-ui.cocoa.views core-foundation threads math.geometry.rect ;
-IN: ui.cocoa
-
-TUPLE: handle view window ;
-
-C: <handle> handle
-
-SINGLETON: cocoa-ui-backend
-
-M: cocoa-ui-backend do-events ( -- )
- [
- [ NSApp [ do-event ] curry loop ui-wait ] ui-try
- ] with-autorelease-pool ;
-
-TUPLE: pasteboard handle ;
-
-C: <pasteboard> pasteboard
-
-M: pasteboard clipboard-contents
- pasteboard-handle pasteboard-string ;
-
-M: pasteboard set-clipboard-contents
- pasteboard-handle set-pasteboard-string ;
-
-: init-clipboard ( -- )
- NSPasteboard -> generalPasteboard <pasteboard>
- clipboard set-global
- <clipboard> selection set-global ;
-
-: world>NSRect ( world -- NSRect )
- dup window-loc>> first2 rot rect-dim first2 <NSRect> ;
-
-: gadget-window ( world -- )
- [
- dup <FactorView>
- dup rot world>NSRect <ViewWindow>
- dup install-window-delegate
- over -> release
- <handle>
- ] keep set-world-handle ;
-
-M: cocoa-ui-backend set-title ( string world -- )
- world-handle handle-window swap <NSString> -> setTitle: ;
-
-: enter-fullscreen ( world -- )
- world-handle handle-view
- NSScreen -> mainScreen
- f -> enterFullScreenMode:withOptions:
- drop ;
-
-: exit-fullscreen ( world -- )
- world-handle handle-view f -> exitFullScreenModeWithOptions: ;
-
-M: cocoa-ui-backend set-fullscreen* ( ? world -- )
- swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
-
-M: cocoa-ui-backend fullscreen* ( world -- ? )
- world-handle handle-view -> isInFullScreenMode zero? not ;
-
-: auto-position ( world -- )
- dup window-loc>> { 0 0 } = [
- world-handle handle-window -> center
- ] [
- drop
- ] if ;
-
-M: cocoa-ui-backend (open-window) ( world -- )
- dup gadget-window
- dup auto-position
- world-handle handle-window f -> makeKeyAndOrderFront: ;
-
-M: cocoa-ui-backend (close-window) ( handle -- )
- handle-window -> release ;
-
-M: cocoa-ui-backend close-window ( gadget -- )
- find-world [
- world-handle [
- handle-window f -> performClose:
- ] when*
- ] when* ;
-
-M: cocoa-ui-backend raise-window* ( world -- )
- world-handle [
- handle-window dup f -> orderFront: -> makeKeyWindow
- NSApp 1 -> activateIgnoringOtherApps:
- ] when* ;
-
-M: cocoa-ui-backend select-gl-context ( handle -- )
- handle-view -> openGLContext -> makeCurrentContext ;
-
-M: cocoa-ui-backend flush-gl-context ( handle -- )
- handle-view -> openGLContext -> flushBuffer ;
-
-M: cocoa-ui-backend beep ( -- )
- NSBeep ;
-
-SYMBOL: cocoa-init-hook
-
-M: cocoa-ui-backend ui
- "UI" assert.app [
- [
- init-clipboard
- cocoa-init-hook get [ call ] when*
- start-ui
- finish-launching
- event-loop
- ] ui-running
- ] with-cocoa ;
-
-cocoa-ui-backend ui-backend set-global
-
-[ running.app? "ui" "listener" ? ] main-vocab-hook set-global
+++ /dev/null
-Cocoa UI backend
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Cocoa integration for UI developer tools
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2006, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax cocoa cocoa.nibs cocoa.application
-cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing
-core-foundation help.topics kernel memory namespaces parser
-system ui ui.tools.browser ui.tools.listener ui.tools.workspace
-ui.cocoa eval ;
-IN: ui.cocoa.tools
-
-: finder-run-files ( alien -- )
- CF>string-array listener-run-files
- NSApp NSApplicationDelegateReplySuccess
- -> replyToOpenOrPrint: ;
-
-: menu-run-files ( -- )
- open-panel [ listener-run-files ] when* ;
-
-: menu-save-image ( -- )
- image save-panel [ save-image ] when* ;
-
-! Handle Open events from the Finder
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorApplicationDelegate" }
-}
-
-{ "application:openFiles:" "void" { "id" "SEL" "id" "id" }
- [ >r 3drop r> finder-run-files ]
-}
-
-{ "newFactorWorkspace:" "id" { "id" "SEL" "id" }
- [ 3drop workspace-window f ]
-}
-
-{ "runFactorFile:" "id" { "id" "SEL" "id" }
- [ 3drop menu-run-files f ]
-}
-
-{ "saveFactorImage:" "id" { "id" "SEL" "id" }
- [ 3drop save f ]
-}
-
-{ "saveFactorImageAs:" "id" { "id" "SEL" "id" }
- [ 3drop menu-save-image f ]
-}
-
-{ "showFactorHelp:" "id" { "id" "SEL" "id" }
- [ 3drop "handbook" com-follow f ]
-} ;
-
-: install-app-delegate ( -- )
- NSApp FactorApplicationDelegate install-delegate ;
-
-! Service support; evaluate Factor code from other apps
-: do-service ( pboard error quot -- )
- pick >r >r
- ?pasteboard-string dup [ r> call ] [ r> 2drop f ] if
- dup [ r> set-pasteboard-string ] [ r> 2drop ] if ;
-
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorServiceProvider" }
-} {
- "evalInListener:userData:error:"
- "void"
- { "id" "SEL" "id" "id" "void*" }
- [ nip [ eval-listener f ] do-service 2drop ]
-} {
- "evalToString:userData:error:"
- "void"
- { "id" "SEL" "id" "id" "void*" }
- [ nip [ eval>string ] do-service 2drop ]
-} ;
-
-: register-services ( -- )
- NSApp
- FactorServiceProvider -> alloc -> init
- -> setServicesProvider: ;
-
-FUNCTION: void NSUpdateDynamicServices ;
-
-[
- install-app-delegate
- "Factor.nib" load-nib
- register-services
-] cocoa-init-hook set-global
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Cocoa NSView implementation displaying Factor gadgets
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays assocs cocoa kernel
-math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
-cocoa.application cocoa.pasteboard cocoa.types cocoa.windows
-sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
-core-foundation threads combinators math.geometry.rect ;
-IN: ui.cocoa.views
-
-: send-mouse-moved ( view event -- )
- over >r mouse-location r> window move-hand fire-motion ;
-
-: button ( event -- n )
- #! Cocoa -> Factor UI button mapping
- -> buttonNumber H{ { 0 1 } { 2 2 } { 1 3 } } at ;
-
-: modifiers
- {
- { S+ HEX: 20000 }
- { C+ HEX: 40000 }
- { A+ HEX: 80000 }
- { M+ HEX: 100000 }
- } ;
-
-: key-codes
- H{
- { 71 "CLEAR" }
- { 36 "RET" }
- { 76 "ENTER" }
- { 53 "ESC" }
- { 48 "TAB" }
- { 51 "BACKSPACE" }
- { 115 "HOME" }
- { 117 "DELETE" }
- { 119 "END" }
- { 122 "F1" }
- { 120 "F2" }
- { 99 "F3" }
- { 118 "F4" }
- { 96 "F5" }
- { 97 "F6" }
- { 98 "F7" }
- { 100 "F8" }
- { 123 "LEFT" }
- { 124 "RIGHT" }
- { 125 "DOWN" }
- { 126 "UP" }
- { 116 "PAGE_UP" }
- { 121 "PAGE_DOWN" }
- } ;
-
-: key-code ( event -- string ? )
- dup -> keyCode key-codes at
- [ t ] [ -> charactersIgnoringModifiers CF>string f ] ?if ;
-
-: event-modifiers ( event -- modifiers )
- -> modifierFlags modifiers modifier ;
-
-: key-event>gesture ( event -- modifiers keycode action? )
- dup event-modifiers swap key-code ;
-
-: send-key-event ( view event quot -- ? )
- >r key-event>gesture r> call swap window-focus
- send-gesture ; inline
-
-: send-user-input ( view string -- )
- CF>string swap window-focus user-input ;
-
-: interpret-key-event ( view event -- )
- NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
-
-: send-key-down-event ( view event -- )
- 2dup [ <key-down> ] send-key-event
- [ interpret-key-event ] [ 2drop ] if ;
-
-: send-key-up-event ( view event -- )
- [ <key-up> ] send-key-event drop ;
-
-: mouse-event>gesture ( event -- modifiers button )
- dup event-modifiers swap button ;
-
-: send-button-down$ ( view event -- )
- [ mouse-event>gesture <button-down> ] 2keep
- mouse-location rot window send-button-down ;
-
-: send-button-up$ ( view event -- )
- [ mouse-event>gesture <button-up> ] 2keep
- mouse-location rot window send-button-up ;
-
-: send-wheel$ ( view event -- )
- over >r
- dup -> deltaX sgn neg over -> deltaY sgn neg 2array -rot
- mouse-location
- r> window send-wheel ;
-
-: send-action$ ( view event gesture -- junk )
- >r drop window r> send-action f ;
-
-: add-resize-observer ( observer object -- )
- >r "updateFactorGadgetSize:"
- "NSViewFrameDidChangeNotification" <NSString>
- r> add-observer ;
-
-: string-or-nil? ( NSString -- ? )
- [ CF>string NSStringPboardType = ] [ t ] if* ;
-
-: valid-service? ( gadget send-type return-type -- ? )
- over string-or-nil? over string-or-nil? and [
- drop [ gadget-selection? ] [ drop t ] if
- ] [
- 3drop f
- ] if ;
-
-: NSRect>rect ( NSRect world -- rect )
- >r dup NSRect-x over NSRect-y r>
- rect-dim second swap - 2array
- over NSRect-w rot NSRect-h 2array
- <rect> ;
-
-: rect>NSRect ( rect world -- NSRect )
- over rect-loc first2 rot rect-dim second swap -
- rot rect-dim first2 <NSRect> ;
-
-CLASS: {
- { +superclass+ "NSOpenGLView" }
- { +name+ "FactorView" }
- { +protocols+ { "NSTextInput" } }
-}
-
-! Rendering
-! Rendering
-{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
- [ 3drop window relayout-1 ]
-}
-
-! Events
-{ "acceptsFirstMouse:" "bool" { "id" "SEL" "id" }
- [ 3drop 1 ]
-}
-
-{ "mouseEntered:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
-}
-
-{ "mouseExited:" "void" { "id" "SEL" "id" }
- [ [ 3drop forget-rollover ] ui-try ]
-}
-
-{ "mouseMoved:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
-}
-
-{ "mouseDragged:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
-}
-
-{ "rightMouseDragged:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
-}
-
-{ "otherMouseDragged:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
-}
-
-{ "mouseDown:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-down$ ] ui-try ]
-}
-
-{ "mouseUp:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-up$ ] ui-try ]
-}
-
-{ "rightMouseDown:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-down$ ] ui-try ]
-}
-
-{ "rightMouseUp:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-up$ ] ui-try ]
-}
-
-{ "otherMouseDown:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-down$ ] ui-try ]
-}
-
-{ "otherMouseUp:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-up$ ] ui-try ]
-}
-
-{ "scrollWheel:" "void" { "id" "SEL" "id" }
- [ [ nip send-wheel$ ] ui-try ]
-}
-
-{ "keyDown:" "void" { "id" "SEL" "id" }
- [ [ nip send-key-down-event ] ui-try ]
-}
-
-{ "keyUp:" "void" { "id" "SEL" "id" }
- [ [ nip send-key-up-event ] ui-try ]
-}
-
-{ "cut:" "id" { "id" "SEL" "id" }
- [ [ nip T{ cut-action } send-action$ ] ui-try ]
-}
-
-{ "copy:" "id" { "id" "SEL" "id" }
- [ [ nip T{ copy-action } send-action$ ] ui-try ]
-}
-
-{ "paste:" "id" { "id" "SEL" "id" }
- [ [ nip T{ paste-action } send-action$ ] ui-try ]
-}
-
-{ "delete:" "id" { "id" "SEL" "id" }
- [ [ nip T{ delete-action } send-action$ ] ui-try ]
-}
-
-{ "selectAll:" "id" { "id" "SEL" "id" }
- [ [ nip T{ select-all-action } send-action$ ] ui-try ]
-}
-
-! Multi-touch gestures: this is undocumented.
-! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
-{ "magnifyWithEvent:" "void" { "id" "SEL" "id" }
- [
- nip
- dup -> deltaZ sgn {
- { 1 [ T{ zoom-in-action } send-action$ ] }
- { -1 [ T{ zoom-out-action } send-action$ ] }
- { 0 [ 2drop ] }
- } case
- ]
-}
-
-{ "swipeWithEvent:" "void" { "id" "SEL" "id" }
- [
- nip
- dup -> deltaX sgn {
- { 1 [ T{ left-action } send-action$ ] }
- { -1 [ T{ right-action } send-action$ ] }
- { 0
- [
- dup -> deltaY sgn {
- { 1 [ T{ up-action } send-action$ ] }
- { -1 [ T{ down-action } send-action$ ] }
- { 0 [ 2drop ] }
- } case
- ]
- }
- } case
- ]
-}
-
-! "rotateWithEvent:" "void" { "id" "SEL" "id" }}
-
-{ "acceptsFirstResponder" "bool" { "id" "SEL" }
- [ 2drop 1 ]
-}
-
-! Services
-{ "validRequestorForSendType:returnType:" "id" { "id" "SEL" "id" "id" }
- [
- ! We return either self or nil
- >r >r over window-focus r> r>
- valid-service? [ drop ] [ 2drop f ] if
- ]
-}
-
-{ "writeSelectionToPasteboard:types:" "bool" { "id" "SEL" "id" "id" }
- [
- CF>string-array NSStringPboardType swap member? [
- >r drop window-focus gadget-selection dup [
- r> set-pasteboard-string t
- ] [
- r> 2drop f
- ] if
- ] [
- 3drop f
- ] if
- ]
-}
-
-{ "readSelectionFromPasteboard:" "bool" { "id" "SEL" "id" }
- [
- pasteboard-string dup [
- >r drop window-focus r> swap user-input t
- ] [
- 3drop f
- ] if
- ]
-}
-
-! Text input
-{ "insertText:" "void" { "id" "SEL" "id" }
- [ [ nip send-user-input ] ui-try ]
-}
-
-{ "hasMarkedText" "bool" { "id" "SEL" }
- [ 2drop 0 ]
-}
-
-{ "markedRange" "NSRange" { "id" "SEL" }
- [ 2drop 0 0 <NSRange> ]
-}
-
-{ "selectedRange" "NSRange" { "id" "SEL" }
- [ 2drop 0 0 <NSRange> ]
-}
-
-{ "setMarkedText:selectedRange:" "void" { "id" "SEL" "id" "NSRange" }
- [ 2drop 2drop ]
-}
-
-{ "unmarkText" "void" { "id" "SEL" }
- [ 2drop ]
-}
-
-{ "validAttributesForMarkedText" "id" { "id" "SEL" }
- [ 2drop NSArray -> array ]
-}
-
-{ "attributedSubstringFromRange:" "id" { "id" "SEL" "NSRange" }
- [ 3drop f ]
-}
-
-{ "characterIndexForPoint:" "uint" { "id" "SEL" "NSPoint" }
- [ 3drop 0 ]
-}
-
-{ "firstRectForCharacterRange:" "NSRect" { "id" "SEL" "NSRange" }
- [ 3drop 0 0 0 0 <NSRect> ]
-}
-
-{ "conversationIdentifier" "long" { "id" "SEL" }
- [ drop alien-address ]
-}
-
-! Initialization
-{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
- [
- [
- 2drop dup view-dim swap window (>>dim) yield
- ] ui-try
- ]
-}
-
-{ "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }
- [
- rot drop
- SUPER-> initWithFrame:pixelFormat:
- dup dup add-resize-observer
- ]
-}
-
-{ "dealloc" "void" { "id" "SEL" }
- [
- drop
- dup unregister-window
- dup remove-observer
- SUPER-> dealloc
- ]
-} ;
-
-: sync-refresh-to-screen ( GLView -- )
- -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
- CGLSetParameter drop ;
-
-: <FactorView> ( world -- view )
- FactorView over rect-dim <GLView>
- [ sync-refresh-to-screen ] keep
- [ register-window ] keep ;
-
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorWindowDelegate" }
-}
-
-{ "windowDidMove:" "void" { "id" "SEL" "id" }
- [
- 2nip -> object
- dup window-content-rect NSRect-x-y 2array
- swap -> contentView window (>>window-loc)
- ]
-}
-
-{ "windowDidBecomeKey:" "void" { "id" "SEL" "id" }
- [
- 2nip -> object -> contentView window focus-world
- ]
-}
-
-{ "windowDidResignKey:" "void" { "id" "SEL" "id" }
- [
- forget-rollover
- 2nip -> object -> contentView window unfocus-world
- ]
-}
-
-{ "windowShouldClose:" "bool" { "id" "SEL" "id" }
- [
- 3drop t
- ]
-}
-
-{ "windowWillClose:" "void" { "id" "SEL" "id" }
- [
- 2nip -> object -> contentView window ungraft
- ]
-} ;
-
-: install-window-delegate ( window -- )
- FactorWindowDelegate install-delegate ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: accessors ui.gestures help.markup help.syntax strings kernel
-hashtables quotations words classes sequences namespaces
-arrays assocs ;
-IN: ui.commands
-
-: command-map-row ( gesture command -- seq )
- [
- [ gesture>string , ]
- [
- [ command-name , ]
- [ command-word \ $link swap 2array , ]
- [ command-description , ]
- tri
- ] bi*
- ] { } make ;
-
-: command-map. ( alist -- )
- [ command-map-row ] { } assoc>map
- { "Shortcut" "Command" "Word" "Notes" }
- [ \ $strong swap ] { } map>assoc prefix
- $table ;
-
-: $command-map ( element -- )
- [ second (command-name) " commands" append $heading ]
- [
- first2 swap command-map
- [ blurb>> print-element ] [ commands>> command-map. ] bi
- ] bi ;
-
-: $command ( element -- )
- reverse first3 command-map
- commands>> value-at gesture>string
- $snippet ;
-
-HELP: +nullary+
-{ $description "A key which may be set in the hashtable passed to " { $link define-command } ". If set to a true value, the command does not take any inputs, and the value passed to " { $link invoke-command } " will be ignored. Otherwise, it takes one input." } ;
-
-HELP: +listener+
-{ $description "A key which may be set in the hashtable passed to " { $link define-command } ". If set to a true value, " { $link invoke-command } " will run the command in the listener. Otherwise it will run in the event loop." } ;
-
-HELP: +description+
-{ $description "A key which may be set in the hashtable passed to " { $link define-command } ". The value is a string displayed as part of the command's documentation by " { $link $command-map } "." } ;
-
-HELP: invoke-command
-{ $values { "target" object } { "command" "a command" } }
-{ $description "Invokes a command on the given target object." } ;
-
-{ invoke-command +nullary+ } related-words
-
-HELP: command-name
-{ $values { "command" "a command" } { "str" "a string" } }
-{ $description "Outputs a human-readable name for the command." }
-{ $examples
- { $example
- "USING: io ui.commands ;"
- "IN: scratchpad"
- ": com-my-command ;"
- "\\ com-my-command command-name write"
- "My Command"
- }
-} ;
-
-HELP: command-description
-{ $values { "command" "a command" } { "str/f" "a string or " { $link f } } }
-{ $description "Outputs the command's description." } ;
-
-{ command-description +description+ } related-words
-
-HELP: command-word
-{ $values { "command" "a command" } { "word" word } }
-{ $description "Outputs the word that will be executed by " { $link invoke-command } ". This is only used for documentation purposes." } ;
-
-HELP: command-map
-{ $values { "group" string } { "class" "a class word" } { "command-map" "a " { $link command-map } " or " { $link f } } }
-{ $description "Outputs a named command map defined on a class." }
-{ $class-description "A command map stores a group of related commands. The " { $snippet "commands" } " slot stores an association list mapping gestures to commands, and the " { $snippet "blurb" } " slot stores an optional one-line description string of this command map."
-$nl
-"Command maps are created by calling " { $link <command-map> } " or " { $link define-command-map } "." } ;
-
-HELP: commands
-{ $values { "class" "a class word" } { "hash" hashtable } }
-{ $description "Outputs a hashtable mapping command map names to " { $link command-map } " instances." } ;
-
-HELP: define-command-map
-{ $values { "class" "a class word" } { "group" string } { "blurb" "a " { $link string } " or " { $link f } } { "pairs" "a sequence of gesture/word pairs" } }
-{ $description
- "Defines a command map on the specified gadget class. The " { $snippet "specs" } " parameter is a sequence of pairs " { $snippet "{ gesture word }" } ". The words must be valid commands; see " { $link define-command } "."
-}
-{ $notes "Only one of " { $link define-command-map } " and " { $link set-gestures } " can be used on a given gadget class, since each word will overwrite the other word's definitions." } ;
-
-HELP: $command-map
-{ $values { "element" "a pair " { $snippet "{ class map }" } } }
-{ $description "Prints a command map, where the first element of the pair is a class word and the second is a command map name." } ;
-
-HELP: $command
-{ $values { "element" "a triple " { $snippet "{ class map command }" } } }
-{ $description "Prints the keyboard shortcut associated with " { $snippet "command" } " in the command map named " { $snippet "map" } " on the class " { $snippet "class" } "." } ;
-
-HELP: define-command
-{ $values { "word" word } { "hash" hashtable } }
-{ $description "Defines a command. The hashtable can contain the following keys:"
- { $list
- { { $link +nullary+ } " - if set to a true value, the word must have stack effect " { $snippet "( -- )" } "; otherwise it must have stack effect " { $snippet "( target -- )" } }
- { { $link +listener+ } " - if set to a true value, the command will run in the listener" }
- { { $link +description+ } " - can be set to a string description of the command" }
- }
-} ;
-
-HELP: command-string
-{ $values { "gesture" "a gesture" } { "command" "a command" } { "string" string } }
-{ $description "Outputs a string containing the command name followed by the gesture." }
-{ $examples
- { $example
- "USING: io ui.commands ui.gestures ;"
- "IN: scratchpad"
- ": com-my-command ;"
- "T{ key-down f { C+ } \"s\" } \\ com-my-command command-string write"
- "My Command (C+s)"
- }
-} ;
-
-ARTICLE: "ui-commands" "Commands"
-"Commands are an abstraction layered on top of gestures. Their main advantage is that they are identified by words and can be organized into " { $emphasis "command maps" } ". This allows easy construction of buttons and tool bars for invoking commands."
-{ $subsection define-command }
-"Command groups are defined on gadget classes:"
-{ $subsection define-command-map }
-"Commands can be introspected and invoked:"
-{ $subsection commands }
-{ $subsection command-map }
-{ $subsection invoke-command }
-"Gadgets for invoking commands are documented in " { $link "ui.gadgets.buttons" } "."
-$nl
-"When documenting gadgets, command documentation can be automatically generated:"
-{ $subsection $command-map }
-{ $subsection $command } ;
-
-ABOUT: "ui-commands"
+++ /dev/null
-IN: ui.commands.tests
-USING: ui.commands ui.gestures tools.test help.markup io
-io.streams.string ;
-
-[ "A+a" ] [ T{ key-down f { A+ } "a" } gesture>string ] unit-test
-[ "b" ] [ T{ key-down f f "b" } gesture>string ] unit-test
-[ "Press Button 2" ] [ T{ button-down f f 2 } gesture>string ] unit-test
-
-: com-test-1 ;
-
-\ com-test-1 H{ } define-command
-
-[ [ 3 com-test-1 ] ] [ 3 \ com-test-1 command-quot ] unit-test
-
-: com-test-2 ;
-
-\ com-test-2 H{ { +nullary+ t } } define-command
-
-[ [ com-test-2 ] ] [ 3 \ com-test-2 command-quot ] unit-test
-
-SYMBOL: testing
-
-testing "testing" "hey" {
- { T{ key-down f { C+ } "x" } com-test-1 }
-} define-command-map
-
-[ "C+x" ] [
- [
- { $command testing "testing" com-test-1 } print-element
- ] with-string-writer
-] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays definitions kernel sequences strings
-math assocs words generic namespaces assocs quotations splitting
-ui.gestures unicode.case unicode.categories tr ;
-IN: ui.commands
-
-SYMBOL: +nullary+
-SYMBOL: +listener+
-SYMBOL: +description+
-
-PREDICATE: listener-command < word +listener+ word-prop ;
-
-GENERIC: invoke-command ( target command -- )
-
-GENERIC: command-name ( command -- str )
-
-TUPLE: command-map blurb commands ;
-
-GENERIC: command-description ( command -- str/f )
-
-GENERIC: command-word ( command -- word )
-
-: <command-map> ( blurb commands -- command-map )
- { } like \ command-map boa ;
-
-: commands ( class -- hash )
- dup "commands" word-prop [ ] [
- H{ } clone [ "commands" set-word-prop ] keep
- ] ?if ;
-
-: command-map ( group class -- command-map )
- commands at ;
-
-: command-gestures ( class -- hash )
- commands values [
- [
- commands>>
- [ drop ] assoc-filter
- [ [ invoke-command ] curry swap set ] assoc-each
- ] each
- ] H{ } make-assoc ;
-
-: update-gestures ( class -- )
- dup command-gestures "gestures" set-word-prop ;
-
-: define-command-map ( class group blurb pairs -- )
- <command-map>
- swap pick commands set-at
- update-gestures ;
-
-TR: convert-command-name "-" " " ;
-
-: (command-name) ( string -- newstring )
- convert-command-name >title ;
-
-M: word command-name ( word -- str )
- name>>
- "com-" ?head drop
- dup first Letter? [ rest ] unless
- (command-name) ;
-
-M: word command-description ( word -- str )
- +description+ word-prop ;
-
-: default-flags ( -- assoc )
- H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
-
-: define-command ( word hash -- )
- [ props>> ] [ default-flags swap assoc-union ] bi* update ;
-
-: command-quot ( target command -- quot )
- dup 1quotation swap +nullary+ word-prop
- [ nip ] [ curry ] if ;
-
-M: word invoke-command ( target command -- )
- command-quot call ;
-
-M: word command-word ;
-
-M: f invoke-command ( target command -- ) 2drop ;
-
-: command-string ( gesture command -- string )
- [
- command-name %
- gesture>string [ " (" % % ")" % ] when*
- ] "" make ;
+++ /dev/null
-UI command framework
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.syntax help.markup strings kernel alien opengl
-quotations ui.render io.styles freetype ;
-IN: ui.freetype
-
-HELP: freetype
-{ $values { "alien" alien } }
-{ $description "Outputs a native handle used by the FreeType library, initializing FreeType first if necessary." } ;
-
-HELP: open-fonts
-{ $var-description "Global variable. Hashtable mapping font descriptors to " { $link font } " instances." } ;
-
-{ font open-fonts open-font char-width string-width text-dim draw-string draw-text } related-words
-
-HELP: init-freetype
-{ $description "Initializes the FreeType library." }
-{ $notes "Do not call this word if you are using the UI." } ;
-
-HELP: font
-{ $class-description "A font which has been loaded by FreeType. Font instances have the following slots:"
- { $list
- { { $link font-ascent } ", " { $link font-descent } ", " { $link font-height } " - metrics." }
- { { $link font-handle } " - alien pointer to an " { $snippet "FT_Face" } "." }
- { { $link font-widths } " - sequence of character widths. Use " { $link char-width } " and " { $link string-width } " to compute string widths instead of reading this sequence directly." }
- }
-} ;
-
-HELP: close-freetype
-{ $description "Closes the FreeType library." }
-{ $notes "Do not call this word if you are using the UI." } ;
-
-HELP: open-face
-{ $values { "font" string } { "style" "one of " { $link plain } ", " { $link bold } ", " { $link italic } " or " { $link bold-italic } } { "face" "alien pointer to an " { $snippet "FT_Face" } } }
-{ $description "Loads a TrueType font with the requested logical font name and style." }
-{ $notes "This is a low-level word. Call " { $link open-font } " instead." } ;
-
-HELP: render-glyph
-{ $values { "font" font } { "char" "a non-negative integer" } { "bitmap" alien } }
-{ $description "Renders a character and outputs a pointer to the bitmap." } ;
-
-HELP: <char-sprite>
-{ $values { "open-font" font } { "char" "a non-negative integer" } { "sprite" sprite } }
-{ $description "Renders a character to an OpenGL texture and records a display list which draws a quad with this texture. This word allocates native resources which must be freed by " { $link free-sprites } "." } ;
-
-HELP: (draw-string)
-{ $values { "open-font" font } { "sprites" "a vector of " { $link sprite } " instances" } { "string" string } { "loc" "a pair of integers" } }
-{ $description "Draws a line of text." }
-{ $notes "This is a low-level word, UI code should use " { $link draw-string } " or " { $link draw-text } " instead." }
-{ $side-effects "sprites" } ;
-
-HELP: run-char-widths
-{ $values { "open-font" font } { "string" string } { "widths" "a sequence of integers" } }
-{ $description "Outputs a sequence of x co-ordinates of the midpoint of each character in the string." }
-{ $notes "This word is used to convert x offsets to document locations, for example when the user moves the caret by clicking the mouse." } ;
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors alien.c-types arrays io kernel libc
-math math.vectors namespaces opengl opengl.gl prettyprint assocs
-sequences io.files io.styles continuations freetype
-ui.gadgets.worlds ui.render ui.backend byte-arrays accessors
-locals ;
-
-IN: ui.freetype
-
-TUPLE: freetype-renderer ;
-
-SYMBOL: open-fonts
-
-: freetype-error ( n -- )
- zero? [ "FreeType error" throw ] unless ;
-
-DEFER: freetype
-
-: init-freetype ( -- )
- global [
- f <void*> dup FT_Init_FreeType freetype-error
- *void* \ freetype set
- H{ } clone open-fonts set
- ] bind ;
-
-: freetype ( -- alien )
- \ freetype get-global expired? [ init-freetype ] when
- \ freetype get-global ;
-
-TUPLE: font < identity-tuple
-ascent descent height handle widths ;
-
-M: font hashcode* drop font hashcode* ;
-
-: close-font ( font -- ) font-handle FT_Done_Face ;
-
-: close-freetype ( -- )
- global [
- open-fonts [ [ drop close-font ] assoc-each f ] change
- freetype [ FT_Done_FreeType f ] change
- ] bind ;
-
-M: freetype-renderer free-fonts ( world -- )
- [ handle>> select-gl-context ]
- [ fonts>> [ nip second free-sprites ] assoc-each ] bi ;
-
-: ttf-name ( font style -- name )
- 2array H{
- { { "monospace" plain } "VeraMono" }
- { { "monospace" bold } "VeraMoBd" }
- { { "monospace" bold-italic } "VeraMoBI" }
- { { "monospace" italic } "VeraMoIt" }
- { { "sans-serif" plain } "Vera" }
- { { "sans-serif" bold } "VeraBd" }
- { { "sans-serif" bold-italic } "VeraBI" }
- { { "sans-serif" italic } "VeraIt" }
- { { "serif" plain } "VeraSe" }
- { { "serif" bold } "VeraSeBd" }
- { { "serif" bold-italic } "VeraBI" }
- { { "serif" italic } "VeraIt" }
- } at ;
-
-: ttf-path ( name -- string )
- "resource:fonts/" swap ".ttf" 3append ;
-
-: (open-face) ( path length -- face )
- #! We use FT_New_Memory_Face, not FT_New_Face, since
- #! FT_New_Face only takes an ASCII path name and causes
- #! problems on localized versions of Windows
- [ freetype ] 2dip 0 f <void*> [
- FT_New_Memory_Face freetype-error
- ] keep *void* ;
-
-: open-face ( font style -- face )
- ttf-name ttf-path malloc-file-contents (open-face) ;
-
-SYMBOL: dpi
-
-72 dpi set-global
-
-: ft-floor -6 shift ; inline
-
-: ft-ceil 63 + -64 bitand -6 shift ; inline
-
-: font-units>pixels ( n font -- n )
- face-size face-size-y-scale FT_MulFix ;
-
-: init-ascent ( font face -- font )
- dup face-y-max swap font-units>pixels >>ascent ; inline
-
-: init-descent ( font face -- font )
- dup face-y-min swap font-units>pixels >>descent ; inline
-
-: init-font ( font -- font )
- dup handle>> init-ascent
- dup handle>> init-descent
- dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline
-
-: set-char-size ( handle size -- )
- 0 swap 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ;
-
-: <font> ( handle -- font )
- font new
- H{ } clone >>widths
- over first2 open-face >>handle
- dup handle>> rot third set-char-size
- init-font ;
-
-M: freetype-renderer open-font ( font -- open-font )
- freetype drop open-fonts get [ <font> ] cache ;
-
-: load-glyph ( font char -- glyph )
- >r font-handle dup r> 0 FT_Load_Char
- freetype-error face-glyph ;
-
-: char-width ( open-font char -- w )
- over font-widths [
- dupd load-glyph glyph-hori-advance ft-ceil
- ] cache nip ;
-
-M: freetype-renderer string-width ( open-font string -- w )
- 0 -rot [ char-width + ] with each ;
-
-M: freetype-renderer string-height ( open-font string -- h )
- drop font-height ;
-
-: glyph-size ( glyph -- dim )
- dup glyph-hori-advance ft-ceil
- swap glyph-height ft-ceil 2array ;
-
-: render-glyph ( font char -- bitmap )
- load-glyph dup
- FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
-
-:: copy-pixel ( i j bitmap texture -- i j )
- 255 j texture set-char-nth
- i bitmap char-nth j 1 + texture set-char-nth
- i 1 + j 2 + ; inline
-
-:: (copy-row) ( i j bitmap texture end -- )
- i end < [
- i j bitmap texture copy-pixel
- bitmap texture end (copy-row)
- ] when ; inline recursive
-
-:: copy-row ( i j bitmap texture width width2 -- i j )
- i j bitmap texture i width + (copy-row)
- i width +
- j width2 + ; inline
-
-:: copy-bitmap ( glyph texture -- )
- [let* | bitmap [ glyph glyph-bitmap-buffer ]
- rows [ glyph glyph-bitmap-rows ]
- width [ glyph glyph-bitmap-width ]
- width2 [ width next-power-of-2 2 * ] |
- 0 0
- rows [ bitmap texture width width2 copy-row ] times
- 2drop
- ] ;
-
-: bitmap>texture ( glyph sprite -- id )
- tuck sprite-size2 * 2 * [
- [ copy-bitmap ] keep gray-texture
- ] with-malloc ;
-
-: glyph-texture-loc ( glyph font -- loc )
- over glyph-hori-bearing-x ft-floor -rot
- font-ascent swap glyph-hori-bearing-y - ft-floor 2array ;
-
-: glyph-texture-size ( glyph -- dim )
- [ glyph-bitmap-width next-power-of-2 ]
- [ glyph-bitmap-rows next-power-of-2 ]
- bi 2array ;
-
-: <char-sprite> ( open-font char -- sprite )
- over >r render-glyph dup r> glyph-texture-loc
- over glyph-size pick glyph-texture-size <sprite>
- [ bitmap>texture ] keep [ init-sprite ] keep ;
-
-:: char-sprite ( open-font sprites char -- sprite )
- char sprites [ open-font swap <char-sprite> ] cache ;
-
-: draw-char ( open-font sprites char loc -- )
- GL_MODELVIEW [
- 0 0 glTranslated
- char-sprite sprite-dlist glCallList
- ] do-matrix ;
-
-: char-widths ( open-font string -- widths )
- [ char-width ] with { } map-as ;
-
-: scan-sums ( seq -- seq' )
- 0 [ + ] accumulate nip ;
-
-:: (draw-string) ( open-font sprites string loc -- )
- GL_TEXTURE_2D [
- loc [
- string open-font string char-widths scan-sums [
- [ open-font sprites ] 2dip draw-char
- ] 2each
- ] with-translation
- ] do-enabled ;
-
-: font-sprites ( font world -- open-font sprites )
- world-fonts [ open-font H{ } clone 2array ] cache first2 ;
-
-M: freetype-renderer draw-string ( font string loc -- )
- >r >r world get font-sprites r> r> (draw-string) ;
-
-: run-char-widths ( open-font string -- widths )
- char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
-
-M: freetype-renderer x>offset ( x open-font string -- n )
- dup >r run-char-widths [ <= ] with find drop
- [ r> drop ] [ r> length ] if* ;
-
-T{ freetype-renderer } font-renderer set-global
+++ /dev/null
-UI text rendering implementation based on FreeType
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax ui.gadgets models ;
-IN: ui.gadgets.books
-
-HELP: book
-{ $class-description "A book is a control containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $link gadget-visible? } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget."
-$nl
-"Books are created by calling " { $link <book> } "." } ;
-
-HELP: <book>
-{ $values { "pages" "a sequence of gadgets" } { "model" model } { "book" book } }
-{ $description "Creates a " { $link book } " control, which contains the gadgets in " { $snippet "pages" } ". A book shows one child at a time, determined by the value of the model, which must be an integer " } ;
-
-ARTICLE: "ui-book-layout" "Book layouts"
-"Books can contain any number of children, and display one child at a time."
-{ $subsection book }
-{ $subsection <book> } ;
-
-ABOUT: "ui-book-layout"
+++ /dev/null
-IN: ui.gadgets.books.tests
-USING: tools.test ui.gadgets.books ;
-
-\ <book> must-infer
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences models ui.gadgets math.geometry.rect ;
-IN: ui.gadgets.books
-
-TUPLE: book < gadget ;
-
-: hide-all ( book -- ) gadget-children [ hide-gadget ] each ;
-
-: current-page ( book -- gadget ) [ control-value ] keep nth-gadget ;
-
-M: book model-changed ( model book -- )
- nip
- dup hide-all
- dup current-page show-gadget
- relayout ;
-
-: new-book ( pages model class -- book )
- new-gadget
- swap >>model
- swap add-gadgets ; inline
-
-: <book> ( pages model -- book ) book new-book ;
-
-M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
-
-M: book layout* ( book -- )
- [ dim>> ] [ children>> ] bi [ (>>dim) ] with each ;
-
-M: book focusable-child* ( book -- child/t ) current-page ;
+++ /dev/null
-Book gadget displays one child at a time
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax ui.gadgets math ;
-IN: ui.gadgets.borders
-
-HELP: border
-{ $class-description "A border gadget contains a single child and centers it, with a fixed-width border. Borders are created by calling " { $link <border> } "." } ;
-
-HELP: <border>
-{ $values { "child" gadget } { "gap" integer } { "border" "a new " { $link border } } }
-{ $description "Creates a new border around the child with the specified horizontal and vertical gap." } ;
-
-ARTICLE: "ui.gadgets.borders" "Border gadgets"
-"Border gadgets add empty space around a child gadget."
-{ $subsection border }
-{ $subsection <border> } ;
-
-ABOUT: "ui.gadgets.borders"
+++ /dev/null
-IN: ui.gadgets.borders.tests
-USING: tools.test accessors namespaces kernel
-ui.gadgets ui.gadgets.borders math.geometry.rect ;
-
-[ { 110 210 } ] [ <gadget> { 100 200 } >>dim 5 <border> pref-dim ] unit-test
-
-[ ] [ <gadget> { 100 200 } >>dim "g" set ] unit-test
-
-[ ] [ "g" get 0 <border> { 100 200 } >>dim "b" set ] unit-test
-
-[ T{ rect f { 0 0 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
-
-[ ] [ "g" get 5 <border> { 210 210 } >>dim "b" set ] unit-test
-
-[ T{ rect f { 55 5 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
-
-[ ] [ "b" get { 0 0 } >>align drop ] unit-test
-
-[ { 5 5 } ] [ "b" get { 100 200 } border-loc ] unit-test
-
-[ T{ rect f { 5 5 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
-
-[ ] [ "b" get { 1 1 } >>fill drop ] unit-test
-
-[ T{ rect f { 5 5 } { 200 200 } } ] [ "b" get border-child-rect ] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays ui.gadgets kernel math
-namespaces vectors sequences math.vectors math.geometry.rect ;
-IN: ui.gadgets.borders
-
-TUPLE: border < gadget
-{ size initial: { 0 0 } }
-{ fill initial: { 0 0 } }
-{ align initial: { 1/2 1/2 } } ;
-
-: new-border ( child class -- border )
- new-gadget [ swap add-gadget drop ] keep ; inline
-
-: <border> ( child gap -- border )
- swap border new-border
- swap dup 2array >>size ;
-
-M: border pref-dim*
- [ size>> 2 v*n ] keep
- gadget-child pref-dim v+ ;
-
-: border-major-dim ( border -- dim )
- [ dim>> ] [ size>> 2 v*n ] bi v- ;
-
-: border-minor-dim ( border -- dim )
- gadget-child pref-dim ;
-
-: scale ( a b s -- c )
- tuck { 1 1 } swap v- [ v* ] 2bi@ v+ ;
-
-: border-dim ( border -- dim )
- [ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ;
-
-: border-loc ( border dim -- loc )
- [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip
- v- v* v+ [ >fixnum ] map ;
-
-: border-child-rect ( border -- rect )
- dup border-dim [ border-loc ] keep <rect> ;
-
-M: border layout*
- dup border-child-rect swap gadget-child
- over loc>> over set-rect-loc
- swap dim>> swap (>>dim) ;
-
-M: border focusable-child*
- gadget-child ;
+++ /dev/null
-Border gadget adds padding around a child
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax ui.gadgets ui.gadgets.labels
-ui.render kernel models classes ;
-IN: ui.gadgets.buttons
-
-HELP: button
-{ $class-description "A button is a " { $link gadget } " which responds to mouse clicks by invoking a quotation."
-$nl
-"A button's appearance can vary depending on the state of the mouse button if the " { $link gadget-interior } " or " { $link gadget-boundary } " slots are set to instances of " { $link button-paint } "."
-$nl
-"A button can be selected, which is distinct from being pressed. This state is held in the " { $link button-selected? } " slot, and is used by the " { $link <toggle-buttons> } " word to construct a row of buttons for choosing among several alternatives." } ;
-
-HELP: <button>
-{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" "a new " { $link button } } }
-{ $description "Creates a new " { $link button } " which calls the quotation when clicked. The given gadget becomes the button's only child." } ;
-
-HELP: <roll-button>
-{ $values { "label" "a label specifier" } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" button } }
-{ $description "Creates a new " { $link button } " which is displayed with a solid border when it is under the mouse, informing the user that the gadget is clickable." } ;
-
-HELP: <bevel-button>
-{ $values { "label" "a label specifier" } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" button } }
-{ $description "Creates a new " { $link button } " with a shaded border which is always visible. The button appearance changes in response to mouse gestures using a " { $link button-paint } "." } ;
-
-HELP: <repeat-button>
-{ $values { "label" object } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" repeat-button } }
-{ $description "Creates a new " { $link button } " derived from a " { $link <bevel-button> } " which calls the quotation every 100 milliseconds as long as the mouse button is held down." } ;
-
-HELP: button-paint
-{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " gneeric words by delegating to an object in one of four slots which depend on the state of the button being drawn:"
- { $list
- { { $link button-paint-plain } " - the button is inactive" }
- { { $link button-paint-rollover } " - the button is under the mouse" }
- { { $link button-paint-pressed } " - the button is under the mouse and a mouse button is held down" }
- { { $link button-paint-selected } " - the button is selected (see " { $link <toggle-buttons> } }
- }
-"The " { $link <roll-button> } " and " { $link <bevel-button> } " words create " { $link button } " instances with specific " { $link button-paint } "." } ;
-
-HELP: <toggle-button>
-{ $values { "model" model } { "value" object } { "label" "a label specifier" } { "gadget" gadget } }
-{ $description
- "Creates a " { $link <bevel-button> } " which sets the model's value to " { $snippet "value" } " when pressed. After being pressed, the button becomes selected until the value of the model changes again."
-}
-{ $notes "Typically a row of radio controls should be built together using " { $link <toggle-buttons> } "." } ;
-
-HELP: <toggle-buttons>
-{ $values { "model" model } { "assoc" "an association list mapping labels to objects" } { "gadget" gadget } }
-{ $description "Creates a row of labelled " { $link <toggle-button> } " gadgets which change the value of the model." } ;
-
-HELP: <command-button>
-{ $values { "target" object } { "gesture" "a gesture" } { "command" "a command" } { "button" "a new " { $link button } } }
-{ $description "Creates a " { $link <bevel-button> } " which invokes the command on " { $snippet "target" } " when clicked." } ;
-
-HELP: <toolbar>
-{ $values { "target" object } { "toolbar" gadget } }
-{ $description "Creates a row of " { $link <command-button> } " gadgets invoking commands on " { $snippet "target" } ". The commands are taken from the " { $snippet "\"toolbar\"" } " command group of each class in " { $snippet "classes" } "." } ;
-
-ARTICLE: "ui.gadgets.buttons" "Button gadgets"
-"Buttons respond to mouse clicks by invoking a quotation."
-{ $subsection button }
-"There are many ways to create a new button:"
-{ $subsection <button> }
-{ $subsection <roll-button> }
-{ $subsection <bevel-button> }
-{ $subsection <repeat-button> }
-"Gadgets for invoking commands:"
-{ $subsection <command-button> }
-{ $subsection <toolbar> }
-"A radio box is a row of buttons for choosing amongst several distinct possibilities:"
-{ $subsection <toggle-buttons> }
-"Button appearance can be customized:"
-{ $subsection button-paint }
-"Button constructors take " { $emphasis "label specifiers" } " as input. A label specifier is either a string, an array of strings, a gadget or " { $link f } "."
-{ $see-also <command-button> "ui-commands" } ;
+++ /dev/null
-IN: ui.gadgets.buttons.tests
-USING: ui.commands ui.gadgets.buttons ui.gadgets.labels
-ui.gadgets tools.test namespaces sequences kernel models ;
-
-TUPLE: foo-gadget ;
-
-: com-foo-a ;
-
-: com-foo-b ;
-
-\ foo-gadget "toolbar" f {
- { f com-foo-a }
- { f com-foo-b }
-} define-command-map
-
-T{ foo-gadget } <toolbar> "t" set
-
-[ 2 ] [ "t" get gadget-children length ] unit-test
-[ "Foo A" ] [ "t" get gadget-child gadget-child label-string ] unit-test
-
-[ ] [
- 2 <model> {
- { 0 "atheist" }
- { 1 "christian" }
- { 2 "muslim" }
- { 3 "jewish" }
- } <radio-buttons> "religion" set
-] unit-test
-
-\ <radio-buttons> must-infer
-
-\ <toggle-buttons> must-infer
-
-\ <checkbox> must-infer
-
-[ 0 ] [
- "religion" get gadget-child radio-control-value
-] unit-test
-
-[ 2 ] [
- "religion" get gadget-child control-value
-] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel math models namespaces sequences
- strings quotations assocs combinators classes colors
- classes.tuple opengl math.vectors
- ui.commands ui.gadgets ui.gadgets.borders
- ui.gadgets.labels ui.gadgets.theme
- ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
- ui.render math.geometry.rect ;
-
-IN: ui.gadgets.buttons
-
-TUPLE: button < border pressed? selected? quot ;
-
-: buttons-down? ( -- ? )
- hand-buttons get-global empty? not ;
-
-: button-rollover? ( button -- ? )
- hand-gadget get-global child? ;
-
-: mouse-clicked? ( gadget -- ? )
- hand-clicked get-global child? ;
-
-: button-update ( button -- )
- dup mouse-clicked?
- over button-rollover? and
- buttons-down? and
- over set-button-pressed?
- relayout-1 ;
-
-: if-clicked ( button quot -- )
- >r dup button-update dup button-rollover? r> [ drop ] if ;
-
-: button-clicked ( button -- )
- dup button-quot if-clicked ;
-
-button H{
- { T{ button-up } [ button-clicked ] }
- { T{ button-down } [ button-update ] }
- { T{ mouse-leave } [ button-update ] }
- { T{ mouse-enter } [ button-update ] }
-} set-gestures
-
-: new-button ( label quot class -- button )
- [ swap >label ] dip new-border swap >>quot ; inline
-
-: <button> ( label quot -- button )
- button new-button ;
-
-TUPLE: button-paint plain rollover pressed selected ;
-
-C: <button-paint> button-paint
-
-: find-button ( gadget -- button )
- [ [ button? ] is? ] find-parent ;
-
-: button-paint ( button paint -- button paint )
- over find-button {
- { [ dup pressed?>> ] [ drop pressed>> ] }
- { [ dup selected?>> ] [ drop selected>> ] }
- { [ dup button-rollover? ] [ drop rollover>> ] }
- [ drop plain>> ]
- } cond ;
-
-M: button-paint draw-interior
- button-paint draw-interior ;
-
-M: button-paint draw-boundary
- button-paint draw-boundary ;
-
-: roll-button-theme ( button -- button )
- f black <solid> dup f <button-paint> >>boundary
- { 0 1/2 } >>align ; inline
-
-: <roll-button> ( label quot -- button )
- <button> roll-button-theme ;
-
-: <bevel-button-paint> ( -- paint )
- plain-gradient
- rollover-gradient
- pressed-gradient
- selected-gradient
- <button-paint> ;
-
-: bevel-button-theme ( gadget -- gadget )
- <bevel-button-paint> >>interior
- { 5 5 } >>size
- faint-boundary ; inline
-
-: <bevel-button> ( label quot -- button )
- <button> bevel-button-theme ;
-
-TUPLE: repeat-button < button ;
-
-repeat-button H{
- { T{ drag } [ button-clicked ] }
-} set-gestures
-
-: <repeat-button> ( label quot -- button )
- #! Button that calls the quotation every 100ms as long as
- #! the mouse is held down.
- repeat-button new-button bevel-button-theme ;
-
-TUPLE: checkmark-paint color ;
-
-C: <checkmark-paint> checkmark-paint
-
-M: checkmark-paint draw-interior
- checkmark-paint-color set-color
- origin get [
- rect-dim
- { 0 0 } over gl-line
- dup { 0 1 } v* swap { 1 0 } v* gl-line
- ] with-translation ;
-
-: checkmark-theme ( gadget -- )
- f
- f
- black <solid>
- black <checkmark-paint>
- <button-paint>
- over set-gadget-interior
- black <solid>
- swap set-gadget-boundary ;
-
-: <checkmark> ( -- gadget )
- <gadget>
- dup checkmark-theme
- { 14 14 } over (>>dim) ;
-
-: toggle-model ( model -- )
- [ not ] change-model ;
-
-: checkbox-theme ( gadget -- gadget )
- f >>interior
- { 5 5 } >>gap
- 1/2 >>align ; inline
-
-TUPLE: checkbox < button ;
-
-: <checkbox> ( model label -- checkbox )
- <checkmark> label-on-right checkbox-theme
- [ model>> toggle-model ]
- checkbox new-button
- swap >>model ;
-
-M: checkbox model-changed
- swap model-value over set-button-selected? relayout-1 ;
-
-TUPLE: radio-paint color ;
-
-C: <radio-paint> radio-paint
-
-M: radio-paint draw-interior
- radio-paint-color set-color
- origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
-
-M: radio-paint draw-boundary
- radio-paint-color set-color
- origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
-
-: radio-knob-theme ( gadget -- )
- f
- f
- black <radio-paint>
- black <radio-paint>
- <button-paint>
- over set-gadget-interior
- black <radio-paint>
- swap set-gadget-boundary ;
-
-: <radio-knob> ( -- gadget )
- <gadget>
- dup radio-knob-theme
- { 16 16 } over (>>dim) ;
-
-TUPLE: radio-control < button value ;
-
-: <radio-control> ( value model label -- control )
- [ [ value>> ] keep set-control-value ]
- radio-control new-button
- swap >>model
- swap >>value ; inline
-
-M: radio-control model-changed
- swap model-value
- over radio-control-value =
- over set-button-selected?
- relayout-1 ;
-
-: <radio-controls> ( parent model assoc quot -- parent )
- #! quot has stack effect ( value model label -- )
- swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
-
-: radio-button-theme ( gadget -- gadget )
- { 5 5 } >>gap
- 1/2 >>align ; inline
-
-: <radio-button> ( value model label -- gadget )
- <radio-knob> label-on-right radio-button-theme <radio-control> ;
-
-: radio-buttons-theme ( gadget -- )
- { 5 5 } >>gap drop ;
-
-: <radio-buttons> ( model assoc -- gadget )
- <filled-pile>
- -rot
- [ <radio-button> ] <radio-controls>
- dup radio-buttons-theme ;
-
-: <toggle-button> ( value model label -- gadget )
- <radio-control> bevel-button-theme ;
-
-: <toggle-buttons> ( model assoc -- gadget )
- <shelf>
- -rot
- [ <toggle-button> ] <radio-controls> ;
-
-: command-button-quot ( target command -- quot )
- [ invoke-command drop ] 2curry ;
-
-: <command-button> ( target gesture command -- button )
- [ command-string ] keep
- swapd
- command-button-quot
- <bevel-button> ;
-
-: <toolbar> ( target -- toolbar )
- <shelf>
- swap
- "toolbar" over class command-map commands>> swap
- [ -rot <command-button> add-gadget ] curry assoc-each ;
+++ /dev/null
-Button gadgets invoke commands when clicked
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: ui.backend ui.gadgets ui.gadgets.theme ui.gadgets.lib
-ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces
-classes.tuple colors ;
-IN: ui.gadgets.canvas
-
-TUPLE: canvas < gadget dlist ;
-
-: <canvas> ( -- canvas )
- canvas new-gadget
- black solid-interior ;
-
-: delete-canvas-dlist ( canvas -- )
- dup find-gl-context
- dup canvas-dlist [ delete-dlist ] when*
- f swap set-canvas-dlist ;
-
-: make-canvas-dlist ( canvas quot -- dlist )
- over >r GL_COMPILE swap make-dlist dup r>
- set-canvas-dlist ;
-
-: cache-canvas-dlist ( canvas quot -- dlist )
- over canvas-dlist dup
- [ 2nip ] [ drop make-canvas-dlist ] if ; inline
-
-: draw-canvas ( canvas quot -- )
- origin get [
- cache-canvas-dlist glCallList
- ] with-translation ; inline
-
-M: canvas ungraft* delete-canvas-dlist ;
+++ /dev/null
-
-USING: kernel combinators sequences opengl.gl
- ui.render ui.gadgets ui.gadgets.slate
- accessors ;
-
-IN: ui.gadgets.cartesian
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: cartesian < slate x-min x-max y-min y-max z-min z-max perspective ;
-
-: init-cartesian ( cartesian -- cartesian )
- init-slate
- -10 >>x-min
- 10 >>x-max
- -10 >>y-min
- 10 >>y-max
- -1 >>z-min
- 1 >>z-max ;
-
-: <cartesian> ( -- cartesian ) cartesian new init-cartesian ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: cartesian establish-coordinate-system ( cartesian -- cartesian )
- dup
- {
- [ x-min>> ] [ x-max>> ]
- [ y-min>> ] [ y-max>> ]
- [ z-min>> ] [ z-max>> ]
- }
- cleave
- glOrtho ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: x-range ( cartesian range -- cartesian ) first2 [ >>x-min ] [ >>x-max ] bi* ;
-: y-range ( cartesian range -- cartesian ) first2 [ >>y-min ] [ >>y-max ] bi* ;
-: z-range ( cartesian range -- cartesian ) first2 [ >>z-min ] [ >>z-max ] bi* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: documents help.markup help.syntax ui.gadgets
-ui.gadgets.scrollers models strings ui.commands ;
-IN: ui.gadgets.editors
-
-HELP: editor
-{ $class-description "An editor is a control for editing a multi-line passage of text stored in a " { $link document } " model. Editors are crated by calling " { $link <editor> } "."
-$nl
-"Editors have the following slots:"
-{ $list
- { { $link editor-font } " - a font specifier." }
- { { $link editor-color } " - text color specifier." }
- { { $link editor-caret-color } " - caret color specifier." }
- { { $link editor-selection-color } " - selection background color specifier." }
- { { $link editor-caret } " - a model storing a line/column pair." }
- { { $link editor-mark } " - a model storing a line/column pair. If there is no selection, the mark is equal to the caret, otherwise the mark is located at the opposite end of the selection from the caret." }
- { { $link editor-focused? } " - a boolean." }
-} } ;
-
-HELP: <editor>
-{ $values { "editor" "a new " { $link editor } } }
-{ $description "Creates a new " { $link editor } " with an empty document." } ;
-
-HELP: editor-caret ( editor -- caret )
-{ $values { "editor" editor } { "caret" model } }
-{ $description "Outputs a " { $link model } " holding the current caret location." } ;
-
-{ editor-caret editor-caret* editor-mark editor-mark* } related-words
-
-HELP: editor-caret*
-{ $values { "editor" editor } { "loc" "a pair of integers" } }
-{ $description "Outputs the current caret location as a line/column number pair." } ;
-
-HELP: editor-mark ( editor -- mark )
-{ $values { "editor" editor } { "mark" model } }
-{ $description "Outputs a " { $link model } " holding the current mark location." } ;
-
-HELP: editor-mark*
-{ $values { "editor" editor } { "loc" "a pair of integers" } }
-{ $description "Outputs the current mark location as a line/column number pair." } ;
-
-HELP: change-caret
-{ $values { "editor" editor } { "quot" "a quotation with stack effect " { $snippet "( loc -- newloc )" } } }
-{ $description "Applies a quotation to the current caret location and moves the caret to the location output by the quotation." } ;
-
-{ change-caret change-caret&mark mark>caret } related-words
-
-HELP: mark>caret
-{ $values { "editor" editor } }
-{ $description "Moves the mark to the caret location, effectively deselecting any selected text." } ;
-
-HELP: change-caret&mark
-{ $values { "editor" editor } { "quot" "a quotation with stack effect " { $snippet "( loc -- newloc )" } } }
-{ $description "Applies a quotation to the current caret location and moves the caret and the mark to the location output by the quotation." } ;
-
-HELP: point>loc
-{ $values { "point" "a pair of integers" } { "editor" editor } { "loc" "a pair of integers" } }
-{ $description "Converts a point to a line/column number pair." } ;
-
-HELP: scroll>caret
-{ $values { "editor" editor } }
-{ $description "Ensures that the caret becomes visible in a " { $link scroller } " containing the editor. Does nothing if no parent of " { $snippet "gadget" } " is a " { $link scroller } "." } ;
-
-HELP: remove-selection
-{ $values { "editor" editor } }
-{ $description "Removes currently selected text from the editor's " { $link document } "." } ;
-
-HELP: editor-string
-{ $values { "editor" editor } { "string" string } }
-{ $description "Outputs the contents of the editor's " { $link document } " as a string. Lines are separated by " { $snippet "\\n" } "." } ;
-
-HELP: set-editor-string
-{ $values { "string" string } { "editor" editor } }
-{ $description "Sets the contents of the editor's " { $link document } " to a string, which may use either " { $snippet "\\n" } ", " { $snippet "\\r\\n" } " or " { $snippet "\\r" } " line separators." } ;
-
-ARTICLE: "gadgets-editors-selection" "The caret and mark"
-"If there is no selection, the caret and the mark are at the same location; otherwise the mark delimits the end-point of the selection opposite the caret."
-{ $subsection editor-caret }
-{ $subsection editor-caret* }
-{ $subsection editor-mark }
-{ $subsection editor-mark* }
-{ $subsection change-caret }
-{ $subsection change-caret&mark }
-{ $subsection mark>caret }
-"Getting the selected text:"
-{ $subsection gadget-selection? }
-{ $subsection gadget-selection }
-"Removing selected text:"
-{ $subsection remove-selection }
-"Scrolling to the caret location:"
-{ $subsection scroll>caret }
-"Use " { $link user-input* } " to change selected text." ;
-
-ARTICLE: "gadgets-editors" "Editor gadgets"
-"An editor edits a multi-line passage of text."
-{ $command-map editor "general" }
-{ $command-map editor "caret-motion" }
-{ $command-map editor "selection" }
-{ $heading "Editor words" }
-{ $subsection editor }
-{ $subsection <editor> }
-{ $subsection editor-string }
-{ $subsection set-editor-string }
-{ $subsection "gadgets-editors-selection" }
-{ $subsection "documents" }
-{ $subsection "document-locs-elts" } ;
-
-ABOUT: "gadgets-editors"
+++ /dev/null
-USING: accessors ui.gadgets.editors tools.test kernel io
-io.streams.plain definitions namespaces ui.gadgets
-ui.gadgets.grids prettyprint documents ui.gestures tools.test.ui
-models ;
-
-[ "foo bar" ] [
- <editor> "editor" set
- "editor" get [
- "foo bar" "editor" get set-editor-string
- "editor" get T{ one-line-elt } select-elt
- "editor" get gadget-selection
- ] with-grafted-gadget
-] unit-test
-
-[ "baz quux" ] [
- <editor> "editor" set
- "editor" get [
- "foo bar\nbaz quux" "editor" get set-editor-string
- "editor" get T{ one-line-elt } select-elt
- "editor" get gadget-selection
- ] with-grafted-gadget
-] unit-test
-
-[ ] [
- <editor> "editor" set
- "editor" get [
- "foo bar\nbaz quux" "editor" get set-editor-string
- 4 hand-click# set
- "editor" get position-caret
- ] with-grafted-gadget
-] unit-test
-
-[ "bar" ] [
- <editor> "editor" set
- "editor" get [
- "bar\nbaz quux" "editor" get set-editor-string
- { 0 3 } "editor" get editor-caret set-model
- "editor" get select-word
- "editor" get gadget-selection
- ] with-grafted-gadget
-] unit-test
-
-\ <editor> must-infer
-
-"hello" <model> <field> "field" set
-
-"field" get [
- [ "hello" ] [ "field" get field-model>> model-value ] unit-test
-] with-grafted-gadget
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays documents io kernel math models
-namespaces opengl opengl.gl sequences strings io.styles
-math.vectors sorting colors combinators assocs math.order
-ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
-ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
-ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures
-math.geometry.rect ;
-IN: ui.gadgets.editors
-
-TUPLE: editor < gadget
-font color caret-color selection-color
-caret mark
-focused? ;
-
-: <loc> ( -- loc ) { 0 0 } <model> ;
-
-: init-editor-locs ( editor -- editor )
- <loc> >>caret
- <loc> >>mark ; inline
-
-: editor-theme ( editor -- editor )
- black >>color
- red >>caret-color
- selection-color >>selection-color
- monospace-font >>font ; inline
-
-: new-editor ( class -- editor )
- new-gadget
- <document> >>model
- init-editor-locs
- editor-theme ; inline
-
-: <editor> ( -- editor )
- editor new-editor ;
-
-: activate-editor-model ( editor model -- )
- 2dup add-connection
- dup activate-model
- swap gadget-model add-loc ;
-
-: deactivate-editor-model ( editor model -- )
- 2dup remove-connection
- dup deactivate-model
- swap gadget-model remove-loc ;
-
-M: editor graft*
- dup
- dup editor-caret activate-editor-model
- dup editor-mark activate-editor-model ;
-
-M: editor ungraft*
- dup
- dup editor-caret deactivate-editor-model
- dup editor-mark deactivate-editor-model ;
-
-: editor-caret* ( editor -- loc ) editor-caret model-value ;
-
-: editor-mark* ( editor -- loc ) editor-mark model-value ;
-
-: set-caret ( loc editor -- )
- [ gadget-model validate-loc ] keep
- editor-caret set-model ;
-
-: change-caret ( editor quot -- )
- over >r >r dup editor-caret* swap gadget-model r> call r>
- set-caret ; inline
-
-: mark>caret ( editor -- )
- dup editor-caret* swap editor-mark set-model ;
-
-: change-caret&mark ( editor quot -- )
- over >r change-caret r> mark>caret ; inline
-
-: editor-line ( n editor -- str ) control-value nth ;
-
-: editor-font* ( editor -- font ) editor-font open-font ;
-
-: line-height ( editor -- n )
- editor-font* "" string-height ;
-
-: y>line ( y editor -- line# )
- [ line-height / >fixnum ] keep gadget-model validate-line ;
-
-: point>loc ( point editor -- loc )
- [
- >r first2 r> tuck y>line dup ,
- >r dup editor-font* r>
- rot editor-line x>offset ,
- ] { } make ;
-
-: clicked-loc ( editor -- loc )
- [ hand-rel ] keep point>loc ;
-
-: click-loc ( editor model -- )
- >r clicked-loc r> set-model ;
-
-: focus-editor ( editor -- )
- t over set-editor-focused? relayout-1 ;
-
-: unfocus-editor ( editor -- )
- f over set-editor-focused? relayout-1 ;
-
-: (offset>x) ( font col# str -- x )
- swap head-slice string-width ;
-
-: offset>x ( col# line# editor -- x )
- [ editor-line ] keep editor-font* -rot (offset>x) ;
-
-: loc>x ( loc editor -- x ) >r first2 swap r> offset>x ;
-
-: line>y ( lines# editor -- y )
- line-height * ;
-
-: caret-loc ( editor -- loc )
- [ editor-caret* ] keep 2dup loc>x
- rot first rot line>y 2array ;
-
-: caret-dim ( editor -- dim )
- line-height 0 swap 2array ;
-
-: scroll>caret ( editor -- )
- dup gadget-graft-state second [
- dup caret-loc over caret-dim { 1 0 } v+ <rect>
- over scroll>rect
- ] when drop ;
-
-: draw-caret ( -- )
- editor get editor-focused? [
- editor get
- dup editor-caret-color set-color
- dup caret-loc origin get v+
- swap caret-dim over v+
- [ { 0.5 -0.5 } v+ ] bi@ gl-line
- ] when ;
-
-: line-translation ( n -- loc )
- editor get line-height * 0.0 swap 2array ;
-
-: translate-lines ( n -- )
- line-translation gl-translate ;
-
-: draw-line ( editor str -- )
- >r editor-font r> { 0 0 } draw-string ;
-
-: first-visible-line ( editor -- n )
- clip get rect-loc second origin get second -
- swap y>line ;
-
-: last-visible-line ( editor -- n )
- clip get rect-extent nip second origin get second -
- swap y>line 1+ ;
-
-: with-editor ( editor quot -- )
- [
- swap
- dup first-visible-line \ first-visible-line set
- dup last-visible-line \ last-visible-line set
- dup gadget-model document set
- editor set
- call
- ] with-scope ; inline
-
-: visible-lines ( editor -- seq )
- \ first-visible-line get
- \ last-visible-line get
- rot control-value <slice> ;
-
-: with-editor-translation ( n quot -- )
- >r line-translation origin get v+ r> with-translation ;
- inline
-
-: draw-lines ( -- )
- \ first-visible-line get [
- editor get dup editor-color set-color
- dup visible-lines
- [ draw-line 1 translate-lines ] with each
- ] with-editor-translation ;
-
-: selection-start/end ( editor -- start end )
- dup editor-mark* swap editor-caret* sort-pair ;
-
-: (draw-selection) ( x1 x2 -- )
- 2dup = [ 2 + ] when
- 0.0 swap editor get line-height glRectd ;
-
-: draw-selected-line ( start end n -- )
- [ start/end-on-line ] keep tuck
- >r >r editor get offset>x r> r>
- editor get offset>x
- (draw-selection) ;
-
-: draw-selection ( -- )
- editor get editor-selection-color set-color
- editor get selection-start/end
- over first [
- 2dup [
- >r 2dup r> draw-selected-line
- 1 translate-lines
- ] each-line 2drop
- ] with-editor-translation ;
-
-M: editor draw-gadget*
- [ draw-selection draw-lines draw-caret ] with-editor ;
-
-M: editor pref-dim*
- dup editor-font* swap control-value text-dim ;
-
-: contents-changed ( model editor -- )
- swap
- over caret>> [ over validate-loc ] (change-model)
- over mark>> [ over validate-loc ] (change-model)
- drop relayout ;
-
-: caret/mark-changed ( model editor -- )
- nip [ relayout-1 ] [ scroll>caret ] bi ;
-
-M: editor model-changed
- {
- { [ 2dup model>> eq? ] [ contents-changed ] }
- { [ 2dup caret>> eq? ] [ caret/mark-changed ] }
- { [ 2dup mark>> eq? ] [ caret/mark-changed ] }
- } cond ;
-
-M: editor gadget-selection?
- selection-start/end = not ;
-
-M: editor gadget-selection
- [ selection-start/end ] keep gadget-model doc-range ;
-
-: remove-selection ( editor -- )
- [ selection-start/end ] keep gadget-model remove-doc-range ;
-
-M: editor user-input*
- [ selection-start/end ] keep gadget-model set-doc-range t ;
-
-: editor-string ( editor -- string )
- gadget-model doc-string ;
-
-: set-editor-string ( string editor -- )
- gadget-model set-doc-string ;
-
-M: editor gadget-text* editor-string % ;
-
-: extend-selection ( editor -- )
- dup request-focus dup editor-caret click-loc ;
-
-: mouse-elt ( -- element )
- hand-click# get {
- { 1 T{ one-char-elt } }
- { 2 T{ one-word-elt } }
- } at T{ one-line-elt } or ;
-
-: drag-direction? ( loc editor -- ? )
- editor-mark* before? ;
-
-: drag-selection-caret ( loc editor element -- loc )
- >r [ drag-direction? ] 2keep
- gadget-model
- r> prev/next-elt ? ;
-
-: drag-selection-mark ( loc editor element -- loc )
- >r [ drag-direction? not ] 2keep
- nip dup editor-mark* swap gadget-model
- r> prev/next-elt ? ;
-
-: drag-caret&mark ( editor -- caret mark )
- dup clicked-loc swap mouse-elt
- [ drag-selection-caret ] 3keep
- drag-selection-mark ;
-
-: drag-selection ( editor -- )
- dup drag-caret&mark
- pick editor-mark set-model
- swap editor-caret set-model ;
-
-: editor-cut ( editor clipboard -- )
- dupd gadget-copy remove-selection ;
-
-: delete/backspace ( elt editor quot -- )
- over gadget-selection? [
- drop nip remove-selection
- ] [
- over >r >r dup editor-caret* swap gadget-model
- r> call r> gadget-model remove-doc-range
- ] if ; inline
-
-: editor-delete ( editor elt -- )
- swap [ over >r rot next-elt r> swap ] delete/backspace ;
-
-: editor-backspace ( editor elt -- )
- swap [ over >r rot prev-elt r> ] delete/backspace ;
-
-: editor-select-prev ( editor elt -- )
- swap [ rot prev-elt ] change-caret ;
-
-: editor-prev ( editor elt -- )
- dupd editor-select-prev mark>caret ;
-
-: editor-select-next ( editor elt -- )
- swap [ rot next-elt ] change-caret ;
-
-: editor-next ( editor elt -- )
- dupd editor-select-next mark>caret ;
-
-: editor-select ( from to editor -- )
- tuck editor-caret set-model editor-mark set-model ;
-
-: select-elt ( editor elt -- )
- over >r
- >r dup editor-caret* swap gadget-model r> prev/next-elt
- r> editor-select ;
-
-: start-of-document ( editor -- ) T{ doc-elt } editor-prev ;
-
-: end-of-document ( editor -- ) T{ doc-elt } editor-next ;
-
-: position-caret ( editor -- )
- mouse-elt dup T{ one-char-elt } =
- [ drop dup extend-selection dup editor-mark click-loc ]
- [ select-elt ] if ;
-
-: insert-newline ( editor -- ) "\n" swap user-input ;
-
-: delete-next-character ( editor -- )
- T{ char-elt } editor-delete ;
-
-: delete-previous-character ( editor -- )
- T{ char-elt } editor-backspace ;
-
-: delete-previous-word ( editor -- )
- T{ word-elt } editor-delete ;
-
-: delete-next-word ( editor -- )
- T{ word-elt } editor-backspace ;
-
-: delete-to-start-of-line ( editor -- )
- T{ one-line-elt } editor-delete ;
-
-: delete-to-end-of-line ( editor -- )
- T{ one-line-elt } editor-backspace ;
-
-editor "general" f {
- { T{ key-down f f "DELETE" } delete-next-character }
- { T{ key-down f { S+ } "DELETE" } delete-next-character }
- { T{ key-down f f "BACKSPACE" } delete-previous-character }
- { T{ key-down f { S+ } "BACKSPACE" } delete-previous-character }
- { T{ key-down f { C+ } "DELETE" } delete-previous-word }
- { T{ key-down f { C+ } "BACKSPACE" } delete-next-word }
- { T{ key-down f { A+ } "DELETE" } delete-to-start-of-line }
- { T{ key-down f { A+ } "BACKSPACE" } delete-to-end-of-line }
-} define-command-map
-
-: paste ( editor -- ) clipboard get paste-clipboard ;
-
-: paste-selection ( editor -- ) selection get paste-clipboard ;
-
-: cut ( editor -- ) clipboard get editor-cut ;
-
-editor "clipboard" f {
- { T{ paste-action } paste }
- { T{ button-up f f 2 } paste-selection }
- { T{ copy-action } com-copy }
- { T{ button-up } com-copy-selection }
- { T{ cut-action } cut }
-} define-command-map
-
-: previous-character ( editor -- )
- dup gadget-selection? [
- dup selection-start/end drop
- over set-caret mark>caret
- ] [
- T{ char-elt } editor-prev
- ] if ;
-
-: next-character ( editor -- )
- dup gadget-selection? [
- dup selection-start/end nip
- over set-caret mark>caret
- ] [
- T{ char-elt } editor-next
- ] if ;
-
-: previous-line ( editor -- ) T{ line-elt } editor-prev ;
-
-: next-line ( editor -- ) T{ line-elt } editor-next ;
-
-: previous-word ( editor -- ) T{ word-elt } editor-prev ;
-
-: next-word ( editor -- ) T{ word-elt } editor-next ;
-
-: start-of-line ( editor -- ) T{ one-line-elt } editor-prev ;
-
-: end-of-line ( editor -- ) T{ one-line-elt } editor-next ;
-
-editor "caret-motion" f {
- { T{ button-down } position-caret }
- { T{ key-down f f "LEFT" } previous-character }
- { T{ key-down f f "RIGHT" } next-character }
- { T{ key-down f f "UP" } previous-line }
- { T{ key-down f f "DOWN" } next-line }
- { T{ key-down f { C+ } "LEFT" } previous-word }
- { T{ key-down f { C+ } "RIGHT" } next-word }
- { T{ key-down f f "HOME" } start-of-line }
- { T{ key-down f f "END" } end-of-line }
- { T{ key-down f { C+ } "HOME" } start-of-document }
- { T{ key-down f { C+ } "END" } end-of-document }
-} define-command-map
-
-: select-all ( editor -- ) T{ doc-elt } select-elt ;
-
-: select-line ( editor -- ) T{ one-line-elt } select-elt ;
-
-: select-word ( editor -- ) T{ one-word-elt } select-elt ;
-
-: selected-word ( editor -- string )
- dup gadget-selection?
- [ dup select-word ] unless
- gadget-selection ;
-
-: select-previous-character ( editor -- )
- T{ char-elt } editor-select-prev ;
-
-: select-next-character ( editor -- )
- T{ char-elt } editor-select-next ;
-
-: select-previous-line ( editor -- )
- T{ line-elt } editor-select-prev ;
-
-: select-next-line ( editor -- )
- T{ line-elt } editor-select-next ;
-
-: select-previous-word ( editor -- )
- T{ word-elt } editor-select-prev ;
-
-: select-next-word ( editor -- )
- T{ word-elt } editor-select-next ;
-
-: select-start-of-line ( editor -- )
- T{ one-line-elt } editor-select-prev ;
-
-: select-end-of-line ( editor -- )
- T{ one-line-elt } editor-select-next ;
-
-: select-start-of-document ( editor -- )
- T{ doc-elt } editor-select-prev ;
-
-: select-end-of-document ( editor -- )
- T{ doc-elt } editor-select-next ;
-
-editor "selection" f {
- { T{ button-down f { S+ } } extend-selection }
- { T{ drag } drag-selection }
- { T{ gain-focus } focus-editor }
- { T{ lose-focus } unfocus-editor }
- { T{ delete-action } remove-selection }
- { T{ select-all-action } select-all }
- { T{ key-down f { C+ } "l" } select-line }
- { T{ key-down f { S+ } "LEFT" } select-previous-character }
- { T{ key-down f { S+ } "RIGHT" } select-next-character }
- { T{ key-down f { S+ } "UP" } select-previous-line }
- { T{ key-down f { S+ } "DOWN" } select-next-line }
- { T{ key-down f { S+ C+ } "LEFT" } select-previous-word }
- { T{ key-down f { S+ C+ } "RIGHT" } select-next-word }
- { T{ key-down f { S+ } "HOME" } select-start-of-line }
- { T{ key-down f { S+ } "END" } select-end-of-line }
- { T{ key-down f { S+ C+ } "HOME" } select-start-of-document }
- { T{ key-down f { S+ C+ } "END" } select-end-of-document }
-} define-command-map
-
-! Multi-line editors
-TUPLE: multiline-editor < editor ;
-
-: <multiline-editor> ( -- editor )
- multiline-editor new-editor ;
-
-multiline-editor "general" f {
- { T{ key-down f f "RET" } insert-newline }
- { T{ key-down f { S+ } "RET" } insert-newline }
- { T{ key-down f f "ENTER" } insert-newline }
-} define-command-map
-
-TUPLE: source-editor < multiline-editor ;
-
-: <source-editor> ( -- editor )
- source-editor new-editor ;
-
-! Fields wrap an editor and edit an external model
-TUPLE: field < wrapper field-model editor ;
-
-: field-theme ( gadget -- gadget )
- gray <solid> >>boundary ; inline
-
-: <field-border> ( gadget -- border )
- 2 <border>
- { 1 0 } >>fill
- field-theme ;
-
-: <field> ( model -- gadget )
- <editor> dup <field-border> field new-wrapper
- swap >>editor
- swap >>field-model ;
-
-M: field graft*
- [ [ field-model>> model-value ] [ editor>> ] bi set-editor-string ]
- [ dup editor>> model>> add-connection ]
- bi ;
-
-M: field ungraft*
- dup editor>> model>> remove-connection ;
-
-M: field model-changed
- nip [ editor>> editor-string ] [ field-model>> ] bi set-model ;
+++ /dev/null
-Editors edit a plain text document
+++ /dev/null
-
-USING: kernel alien.c-types combinators sequences splitting grouping
- opengl.gl ui.gadgets ui.render
- math math.vectors accessors math.geometry.rect ;
-
-IN: ui.gadgets.frame-buffer
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: frame-buffer < gadget action pdim last-dim graft ungraft pixels ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-frame-buffer-pixels ( frame-buffer -- frame-buffer )
- dup
- rect-dim product "uint[4]" <c-array>
- >>pixels ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: new-frame-buffer ( class -- gadget )
- new-gadget
- [ ] >>action
- { 100 100 } >>pdim
- [ ] >>graft
- [ ] >>ungraft ;
-
-: <frame-buffer> ( -- frame-buffer ) frame-buffer new-frame-buffer ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: draw-pixels ( fb -- fb )
- dup >r
- dup >r
- rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glDrawPixels
- r> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: read-pixels ( fb -- fb )
- dup >r
- dup >r
- >r
- 0 0 r> rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glReadPixels
- r> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: frame-buffer pref-dim* pdim>> ;
-M: frame-buffer graft* graft>> call ;
-M: frame-buffer ungraft* ungraft>> call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: copy-row ( old new -- )
- 2dup min-length swap >r head-slice 0 r> copy ;
-
-! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
-! [ group ] 2bi@
-! [ copy-row ] 2each ;
-
-! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
-! [ 16 * group ] 2bi@
-! [ copy-row ] 2each ;
-
-: copy-pixels ( old-pixels old-width new-pixels new-width -- )
- [ 16 * <sliced-groups> ] 2bi@
- [ copy-row ] 2each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: frame-buffer layout* ( fb -- )
- {
- {
- [ dup last-dim>> f = ]
- [
- init-frame-buffer-pixels
- dup
- rect-dim >>last-dim
- drop
- ]
- }
- {
- [ dup [ rect-dim ] [ last-dim>> ] bi = not ]
- [
- dup [ pixels>> ] [ last-dim>> first ] bi
-
- rot init-frame-buffer-pixels
- dup rect-dim >>last-dim
-
- [ pixels>> ] [ rect-dim first ] bi
-
- copy-pixels
- ]
- }
- { [ t ] [ drop ] }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: frame-buffer draw-gadget* ( fb -- )
-
- dup rect-dim { 0 1 } v* first2 glRasterPos2i
-
- draw-pixels
-
- dup action>> call
-
- glFlush
-
- read-pixels
-
- drop ;
-
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.syntax help.markup ui.gadgets kernel arrays
-quotations classes.tuple ui.gadgets.grids ;
-IN: ui.gadgets.frames
-
-ARTICLE: "ui-frame-layout" "Frame layouts"
-"Frames resemble " { $link "ui-grid-layout" } " except the size of grid is fixed at 3x3, and the center gadget fills up any available space. Because frames inherit from grids, grid layout words can be used to add and remove children."
-{ $subsection frame }
-"Creating empty frames:"
-{ $subsection <frame> }
-"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add } ":"
-{ $subsection @center }
-{ $subsection @left }
-{ $subsection @right }
-{ $subsection @top }
-{ $subsection @bottom }
-{ $subsection @top-left }
-{ $subsection @top-right }
-{ $subsection @bottom-left }
-{ $subsection @bottom-right } ;
-
-: $ui-frame-constant ( element -- )
- drop
- { $description "Symbolic constant for a common input to " { $link grid-add } "." } print-element ;
-
-HELP: @center $ui-frame-constant ;
-HELP: @left $ui-frame-constant ;
-HELP: @right $ui-frame-constant ;
-HELP: @top $ui-frame-constant ;
-HELP: @bottom $ui-frame-constant ;
-HELP: @top-left $ui-frame-constant ;
-HELP: @top-right $ui-frame-constant ;
-HELP: @bottom-left $ui-frame-constant ;
-HELP: @bottom-right $ui-frame-constant ;
-
-HELP: frame
-{ $class-description "A frame is a gadget which lays out its children in a 3x3 grid. If the frame is enlarged past its preferred size, the center gadget fills up available room."
-$nl
-"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add } " and " { $link grid-remove } "." } ;
-
-HELP: <frame>
-{ $values { "frame" frame } }
-{ $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." } ;
-
-{ grid frame } related-words
-
-ABOUT: "ui-frame-layout"
+++ /dev/null
-IN: ui.gadgets.frames.tests
-USING: ui.gadgets.frames ui.gadgets tools.test ;
-
-[ ] [ <frame> layout ] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic kernel math namespaces sequences words
-splitting grouping math.vectors ui.gadgets.grids ui.gadgets
-math.geometry.rect ;
-IN: ui.gadgets.frames
-
-! A frame arranges gadgets in a 3x3 grid, where the center
-! gadgets gets left-over space.
-TUPLE: frame < grid ;
-
-: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
-
-: @center 1 1 ;
-: @left 0 1 ;
-: @right 2 1 ;
-: @top 1 0 ;
-: @bottom 1 2 ;
-
-: @top-left 0 0 ;
-: @top-right 2 0 ;
-: @bottom-left 0 2 ;
-: @bottom-right 2 2 ;
-
-: new-frame ( class -- frame )
- <frame-grid> swap new-grid ; inline
-
-: <frame> ( -- frame )
- frame new-frame ;
-
-: (fill-center) ( vec n -- )
- over first pick third v+ [v-] 1 rot set-nth ;
-
-: fill-center ( horiz vert dim -- )
- tuck (fill-center) (fill-center) ;
-
-M: frame layout*
- dup compute-grid
- [ rot rect-dim fill-center ] 3keep
- grid-layout ;
+++ /dev/null
-Frames position children around a center child which fills up any remaining space
+++ /dev/null
-USING: help.markup help.syntax opengl kernel strings
- classes.tuple classes quotations models math.geometry.rect ;
-IN: ui.gadgets
-
-HELP: gadget-child
-{ $values { "gadget" gadget } { "child" gadget } }
-{ $description "Outputs the first child of the gadget. Typically this word is used with gadgets which are known to have an only child." } ;
-
-HELP: nth-gadget
-{ $values { "n" "a non-negative integer" } { "gadget" gadget } { "child" gadget } }
-{ $description "Outputs the " { $snippet "n" } "th child of the gadget." }
-{ $errors "Throws an error if " { $snippet "n" } " is negative or greater than or equal to the number of children." } ;
-
-HELP: <gadget>
-{ $values { "gadget" "a new " { $link gadget } } }
-{ $description "Creates a new gadget." } ;
-
-HELP: relative-loc
-{ $values { "fromgadget" gadget } { "togadget" gadget } { "loc" "a pair of integers" } }
-{ $description
- "Outputs the location of the top-left corner of " { $snippet "togadget" } " relative to the co-ordinate system of " { $snippet "fromgadget" } "."
-}
-{ $errors
- "Throws an error if " { $snippet "togadget" } " is not contained in a child of " { $snippet "fromgadget" } "."
-} ;
-
-HELP: user-input*
-{ $values { "str" string } { "gadget" gadget } { "?" "a boolean" } }
-{ $contract "Handle free-form textual input while the gadget has keyboard focus." } ;
-
-HELP: children-on
-{ $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "gadget" gadget } { "seq" "a sequence of gadgets" } }
-{ $contract "Outputs a sequence of gadgets which potentially intersect a rectangle or contain a point in the co-ordinate system of the gadget." }
-{ $notes "This does not have to be an accurate intersection test, and simply returning " { $link gadget-children } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ;
-
-HELP: pick-up
-{ $values { "point" "a pair of integers" } { "gadget" gadget } { "child/f" "a " { $link gadget } " or " { $link f } } }
-{ $description "Outputs the child at a point in the gadget's co-ordinate system. This word recursively descends the gadget hierarchy, and so outputs the deepest child." } ;
-
-HELP: max-dim
-{ $values { "dims" "a sequence of pairs of integers" } { "dim" "a pair of integers" } }
-{ $description "Outputs the smallest dimensions of a rectangle which can fit all the dimensions in the sequence." } ;
-
-{ pref-dims max-dim dim-sum } related-words
-
-HELP: each-child
-{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( child -- )" } } }
-{ $description "Applies the quotation to each child of the gadget." } ;
-
-HELP: gadget-selection?
-{ $values { "gadget" gadget } { "?" "a boolean" } }
-{ $contract "Outputs if the gadget has an active text selection; if so, the selected text can be obtained with a call to " { $link gadget-selection } "." } ;
-
-HELP: gadget-selection
-{ $values { "gadget" gadget } { "string/f" "a " { $link string } " or " { $link f } } }
-{ $contract "Outputs the gadget's text selection, or " { $link f } " if nothing is selected." } ;
-
-HELP: relayout
-{ $values { "gadget" gadget } }
-{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout-1 } ", this relayouts all parents up to a gadget having " { $link gadget-root? } " set, so this word should be used when the gadget's dimensions have potentially changed." } ;
-
-HELP: relayout-1
-{ $values { "gadget" gadget } }
-{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout } ", this does not propagate requests up to the parent, and so this word should only be used when the gadget's internal layout or appearance has changed, but the dimensions have not." } ;
-
-{ relayout relayout-1 } related-words
-
-HELP: pref-dim*
-{ $values { "gadget" gadget } { "dim" "a pair of integers" } }
-{ $contract "Outputs the preferred dimensions of the gadget, possibly computing them from the preferred dimensions of the gadget's children." }
-{ $notes "User code should not call this word directly, instead call " { $link pref-dim } "." } ;
-
-HELP: pref-dim
-{ $values { "gadget" gadget } { "dim" "a pair of integers" } }
-{ $description "Outputs the preferred dimensions of the gadget. The value is cached between calls, and invalidated when the gadget needs to be relayout." } ;
-
-HELP: pref-dims
-{ $values { "gadgets" "a sequence of gadgets" } { "seq" "a sequence of pairs of integers" } }
-{ $description "Collects the preferred dimensions of every gadget in the sequence into a new sequence." } ;
-
-HELP: layout*
-{ $values { "gadget" gadget } }
-{ $contract "Lays out the children of the gadget according to the gadget's policy. The dimensions of the gadget are already set by the parent by the time this word is called." }
-{ $notes "User code should not call this word directly, instead call " { $link relayout } " and " { $link relayout-1 } "." } ;
-
-HELP: prefer
-{ $values { "gadget" gadget } }
-{ $contract "Resizes the gadget to assume its preferred dimensions." } ;
-
-HELP: dim-sum
-{ $values { "seq" "a sequence of pairs of integers" } { "dim" "a pair of integers" } }
-{ $description "Sums a sequence of dimensions." } ;
-
-HELP: layout
-{ $values { "gadget" gadget } }
-{ $description "Lays out the children of the gadget if the gadget needs to be relayout, and otherwise does nothing." }
-{ $notes "User code should not call this word directly, instead call " { $link relayout } " and " { $link relayout-1 } "." } ;
-
-{ pref-dim pref-dim* layout layout* } related-words
-
-HELP: graft*
-{ $values { "gadget" gadget } }
-{ $contract "Called to notify the gadget it has become visible on the screen. This should set up timers and threads, and acquire any resources used by the gadget." } ;
-
-{ graft graft* ungraft ungraft* } related-words
-
-HELP: ungraft*
-{ $values { "gadget" gadget } }
-{ $contract "Called to notify the gadget it is no longer visible on the screen. This should stop timers and threads, and release any resources used by the gadget." } ;
-
-HELP: graft
-{ $values { "gadget" gadget } }
-{ $description "Calls " { $link graft* } " on the gadget and all children." }
-{ $notes "This word should never be called directly." } ;
-
-HELP: ungraft
-{ $values { "gadget" gadget } }
-{ $description "If the gadget is grafted, calls " { $link ungraft* } " on the gadget and all children." }
-{ $notes "This word should never be called directly." } ;
-
-HELP: unparent
-{ $values { "gadget" gadget } }
-{ $description "Removes the gadget from its parent. This will relayout the parent." }
-{ $notes "This may result in " { $link ungraft* } " being called on the gadget and its children, if the gadget's parent is visible on the screen." } ;
-
-HELP: clear-gadget
-{ $values { "gadget" gadget } }
-{ $description "Removes all children from the gadget. This will relayout the gadget." }
-{ $notes "This may result in " { $link ungraft* } " being called on the children, if the gadget is visible on the screen." }
-{ $side-effects "gadget" } ;
-
-HELP: add-gadget
-{ $values { "gadget" gadget } { "parent" gadget } }
-{ $description "Adds a child gadget to a parent. If the gadget is contained in another gadget, " { $link unparent } " is called on the gadget first. The parent will be relayout." }
-{ $notes "Adding a gadget to a parent may result in " { $link graft* } " being called on the children, if the parent is visible on the screen." }
-{ $side-effects "parent" } ;
-
-HELP: add-gadgets
-{ $values { "seq" "a sequence of gadgets" } { "parent" gadget } }
-{ $description "Adds a sequence of gadgets to a parent. The parent will be relayout." }
-{ $notes "This may result in " { $link graft* } " being called on the children, if the parent is visible on the screen." }
-{ $side-effects "parent" } ;
-
-HELP: parents
-{ $values { "gadget" gadget } { "seq" "a sequence of gadgets" } }
-{ $description "Outputs a sequence of all parents of the gadget, with the first element being the gadget itself." } ;
-
-HELP: each-parent
-{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( gadget -- ? )" } } { "?" "a boolean" } }
-{ $description "Applies the quotation to every parent of the gadget, starting from the gadget itself, stopping if the quotation yields " { $link f } ". Outputs " { $link t } " if the iteration completed, and outputs " { $link f } " if it was stopped prematurely." } ;
-
-HELP: find-parent
-{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( gadget -- ? )" } } { "parent" gadget } }
-{ $description "Outputs the first parent of the gadget, starting from the gadget itself, for which the quotation outputs a true value, or " { $link f } " if the quotation outputs " { $link f } " for every parent." } ;
-
-HELP: screen-loc
-{ $values { "gadget" gadget } { "loc" "a pair of integers" } }
-{ $description "Outputs the location of the gadget relative to the top-left corner of the world containing the gadget. This word does not output a useful value if the gadget is not grafted." } ;
-
-HELP: child?
-{ $values { "parent" gadget } { "child" gadget } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "child" } " is contained inside " { $snippet "parent" } "." } ;
-
-HELP: focusable-child*
-{ $values { "gadget" gadget } { "child/t" "a " { $link gadget } " or " { $link t } } }
-{ $description "Outputs the child of the gadget which would prefer to receive keyboard focus, or " { $link t } " if the gadget itself should receive focus." }
-{ $examples "For example, if your gadget consists of an editor together with an output area whose contents react to changes in editor contents, then the " { $link focusable-child* } " method for your gadget class should return the editor, so that when the gadget is displayed in a window or passed to " { $link request-focus } ", the editor receives keyboard focus automatically." } ;
-
-HELP: focusable-child
-{ $values { "gadget" gadget } { "child" gadget } }
-{ $description "Outputs the child of the gadget which would prefer to receive keyboard focus." } ;
-
-{ control-value set-control-value gadget-model } related-words
-
-HELP: control-value
-{ $values { "control" gadget } { "value" object } }
-{ $description "Outputs the value of the control's model." } ;
-
-HELP: set-control-value
-{ $values { "value" object } { "control" gadget } }
-{ $description "Sets the value of the control's model." } ;
-
-ARTICLE: "ui-control-impl" "Implementing controls"
-"A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $link gadget-model } " slot set to a " { $link model } " instance."
-$nl
-"Some utility words useful in control implementations:"
-{ $subsection gadget-model }
-{ $subsection control-value }
-{ $subsection set-control-value }
-{ $see-also "models" } ;
+++ /dev/null
-IN: ui.gadgets.tests
-USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds
-tools.test namespaces models kernel dlists deques math sets
-math.parser ui sequences hashtables assocs io arrays prettyprint
-io.streams.string math.geometry.rect ;
-
-[ { 300 300 } ]
-[
- ! c contains b contains a
- <gadget> "a" set
- <gadget> "b" set
- "a" get "b" get swap add-gadget drop
- <gadget> "c" set
- "b" get "c" get swap add-gadget drop
-
- ! position a and b
- { 100 200 } "a" get set-rect-loc
- { 200 100 } "b" get set-rect-loc
-
- ! give c a loc, it doesn't matter
- { -1000 23 } "c" get set-rect-loc
-
- ! what is the location of a inside c?
- "a" get "c" get relative-loc
-] unit-test
-
-<gadget> "g1" set
-{ 10 10 } "g1" get set-rect-loc
-{ 30 30 } "g1" get set-rect-dim
-<gadget> "g2" set
-{ 20 20 } "g2" get set-rect-loc
-{ 50 500 } "g2" get set-rect-dim
-<gadget> "g3" set
-{ 100 200 } "g3" get set-rect-dim
-
-"g1" get "g2" get swap add-gadget drop
-"g2" get "g3" get swap add-gadget drop
-
-[ { 30 30 } ] [ "g1" get screen-loc ] unit-test
-[ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test
-[ { 30 30 } ] [ "g1" get screen-rect rect-dim ] unit-test
-[ { 20 20 } ] [ "g2" get screen-loc ] unit-test
-[ { 20 20 } ] [ "g2" get screen-rect rect-loc ] unit-test
-[ { 50 180 } ] [ "g2" get screen-rect rect-dim ] unit-test
-[ { 0 0 } ] [ "g3" get screen-loc ] unit-test
-[ { 0 0 } ] [ "g3" get screen-rect rect-loc ] unit-test
-[ { 100 200 } ] [ "g3" get screen-rect rect-dim ] unit-test
-
-<gadget> "g1" set
-{ 300 300 } "g1" get set-rect-dim
-<gadget> "g2" set
-"g2" get "g1" get swap add-gadget drop
-{ 20 20 } "g2" get set-rect-loc
-{ 20 20 } "g2" get set-rect-dim
-<gadget> "g3" set
-"g3" get "g1" get swap add-gadget drop
-{ 100 100 } "g3" get set-rect-loc
-{ 20 20 } "g3" get set-rect-dim
-
-[ t ] [ { 30 30 } "g2" get inside? ] unit-test
-
-[ t ] [ { 30 30 } "g1" get (pick-up) "g2" get eq? ] unit-test
-
-[ t ] [ { 30 30 } "g1" get pick-up "g2" get eq? ] unit-test
-
-[ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test
-
-<gadget> "g4" set
-"g4" get "g2" get swap add-gadget drop
-{ 5 5 } "g4" get set-rect-loc
-{ 1 1 } "g4" get set-rect-dim
-
-[ t ] [ { 25 25 } "g1" get pick-up "g4" get eq? ] unit-test
-
-TUPLE: mock-gadget < gadget graft-called ungraft-called ;
-
-: <mock-gadget> ( -- gadget )
- mock-gadget new-gadget 0 >>graft-called 0 >>ungraft-called ;
-
-M: mock-gadget graft*
- dup mock-gadget-graft-called 1+
- swap set-mock-gadget-graft-called ;
-
-M: mock-gadget ungraft*
- dup mock-gadget-ungraft-called 1+
- swap set-mock-gadget-ungraft-called ;
-
-! We can't print to output-stream here because that might be a pane
-! stream, and our graft-queue rebinding here would be captured
-! by code adding children to the pane...
-[
- <dlist> \ graft-queue [
- [ ] [ <mock-gadget> dup queue-graft unqueue-graft ] unit-test
- [ t ] [ graft-queue deque-empty? ] unit-test
- ] with-variable
-
- <dlist> \ graft-queue [
- [ t ] [ graft-queue deque-empty? ] unit-test
-
- <mock-gadget> "g" set
- [ ] [ "g" get queue-graft ] unit-test
- [ f ] [ graft-queue deque-empty? ] unit-test
- [ { f t } ] [ "g" get gadget-graft-state ] unit-test
- [ ] [ "g" get graft-later ] unit-test
- [ { f t } ] [ "g" get gadget-graft-state ] unit-test
- [ ] [ "g" get ungraft-later ] unit-test
- [ { f f } ] [ "g" get gadget-graft-state ] unit-test
- [ t ] [ graft-queue deque-empty? ] unit-test
- [ ] [ "g" get ungraft-later ] unit-test
- [ ] [ "g" get graft-later ] unit-test
- [ ] [ notify-queued ] unit-test
- [ { t t } ] [ "g" get gadget-graft-state ] unit-test
- [ t ] [ graft-queue deque-empty? ] unit-test
- [ ] [ "g" get graft-later ] unit-test
- [ 1 ] [ "g" get mock-gadget-graft-called ] unit-test
- [ ] [ "g" get ungraft-later ] unit-test
- [ { t f } ] [ "g" get gadget-graft-state ] unit-test
- [ ] [ notify-queued ] unit-test
- [ 1 ] [ "g" get mock-gadget-ungraft-called ] unit-test
- [ { f f } ] [ "g" get gadget-graft-state ] unit-test
- ] with-variable
-
- : add-some-children
- 3 [
- <mock-gadget> over <model> over set-gadget-model
- dup "g" get swap add-gadget drop
- swap 1+ number>string set
- ] each ;
-
- : status-flags
- { "g" "1" "2" "3" } [ get gadget-graft-state ] map prune ;
-
- : notify-combo ( ? ? -- )
- nl "===== Combo: " write 2dup 2array . nl
- <dlist> \ graft-queue [
- <mock-gadget> "g" set
- [ ] [ add-some-children ] unit-test
- [ V{ { f f } } ] [ status-flags ] unit-test
- [ ] [ "g" get graft ] unit-test
- [ V{ { f t } } ] [ status-flags ] unit-test
- dup [ [ ] [ notify-queued ] unit-test ] when
- [ ] [ "g" get clear-gadget ] unit-test
- [ [ 1 ] [ graft-queue dlist-length ] unit-test ] unless
- [ [ ] [ notify-queued ] unit-test ] when
- [ ] [ add-some-children ] unit-test
- [ { f t } ] [ "1" get gadget-graft-state ] unit-test
- [ { f t } ] [ "2" get gadget-graft-state ] unit-test
- [ { f t } ] [ "3" get gadget-graft-state ] unit-test
- [ ] [ graft-queue [ "x" print notify ] slurp-deque ] unit-test
- [ ] [ notify-queued ] unit-test
- [ V{ { t t } } ] [ status-flags ] unit-test
- ] with-variable ;
-
- { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
-] with-string-writer print
-
-\ <gadget> must-infer
-\ unparent must-infer
-\ add-gadget must-infer
-\ add-gadgets must-infer
-\ clear-gadget must-infer
-
-\ relayout must-infer
-\ relayout-1 must-infer
-\ pref-dim must-infer
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays hashtables kernel models math namespaces
- sequences quotations math.vectors combinators sorting
- binary-search vectors dlists deques models threads
- concurrency.flags math.order math.geometry.rect ;
-
-IN: ui.gadgets
-
-SYMBOL: ui-notify-flag
-
-: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
-
-TUPLE: gadget < rect
- pref-dim parent children orientation focus
- visible? root? clipped? layout-state graft-state graft-node
- interior boundary
- model ;
-
-M: gadget equal? 2drop f ;
-
-M: gadget hashcode* drop gadget hashcode* ;
-
-M: gadget model-changed 2drop ;
-
-: gadget-child ( gadget -- child ) children>> first ;
-
-: nth-gadget ( n gadget -- child ) children>> nth ;
-
-: init-gadget ( gadget -- gadget )
- init-rect
- { 0 1 } >>orientation
- t >>visible?
- { f f } >>graft-state ; inline
-
-: new-gadget ( class -- gadget ) new init-gadget ; inline
-
-: <gadget> ( -- gadget )
- gadget new-gadget ;
-
-: activate-control ( gadget -- )
- dup model>> dup [
- 2dup add-connection
- swap model-changed
- ] [
- 2drop
- ] if ;
-
-: deactivate-control ( gadget -- )
- dup model>> dup [ 2dup remove-connection ] when 2drop ;
-
-: control-value ( control -- value )
- model>> model-value ;
-
-: set-control-value ( value control -- )
- model>> set-model ;
-
-: relative-loc ( fromgadget togadget -- loc )
- 2dup eq? [
- 2drop { 0 0 }
- ] [
- over rect-loc >r
- >r parent>> r> relative-loc
- r> v+
- ] if ;
-
-GENERIC: user-input* ( str gadget -- ? )
-
-M: gadget user-input* 2drop t ;
-
-GENERIC: children-on ( rect/point gadget -- seq )
-
-M: gadget children-on nip children>> ;
-
-: ((fast-children-on)) ( gadget dim axis -- <=> )
- [ swap loc>> v- ] dip v. 0 <=> ;
-
-: (fast-children-on) ( dim axis children -- i )
- -rot [ ((fast-children-on)) ] 2curry search drop ;
-
-: fast-children-on ( rect axis children -- from to )
- [ [ rect-loc ] 2dip (fast-children-on) 0 or ]
- [ [ rect-bounds v+ ] 2dip (fast-children-on) ?1+ ]
- 3bi ;
-
-: inside? ( bounds gadget -- ? )
- dup visible?>> [ intersects? ] [ 2drop f ] if ;
-
-: (pick-up) ( point gadget -- gadget )
- dupd children-on [ inside? ] with find-last nip ;
-
-: pick-up ( point gadget -- child/f )
- 2dup (pick-up) dup
- [ nip [ rect-loc v- ] keep pick-up ] [ rot 2drop ] if ;
-
-: max-dim ( dims -- dim ) { 0 0 } [ vmax ] reduce ;
-
-: dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
-
-: orient ( gadget seq1 seq2 -- seq )
- >r >r orientation>> r> r> [ pick set-axis ] 2map nip ;
-
-: each-child ( gadget quot -- )
- >r children>> r> each ; inline
-
-! Selection protocol
-GENERIC: gadget-selection? ( gadget -- ? )
-
-M: gadget gadget-selection? drop f ;
-
-GENERIC: gadget-selection ( gadget -- string/f )
-
-M: gadget gadget-selection drop f ;
-
-! Text protocol
-GENERIC: gadget-text* ( gadget -- )
-
-GENERIC: gadget-text-separator ( gadget -- str )
-
-M: gadget gadget-text-separator
- orientation>> { 0 1 } = "\n" "" ? ;
-
-: gadget-seq-text ( seq gadget -- )
- gadget-text-separator swap
- [ dup % ] [ gadget-text* ] interleave drop ;
-
-M: gadget gadget-text*
- dup children>> swap gadget-seq-text ;
-
-M: array gadget-text*
- [ gadget-text* ] each ;
-
-: gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
-
-: invalidate ( gadget -- )
- \ invalidate swap (>>layout-state) ;
-
-: forget-pref-dim ( gadget -- ) f swap (>>pref-dim) ;
-
-: layout-queue ( -- queue ) \ layout-queue get ;
-
-: layout-later ( gadget -- )
- #! When unit testing gadgets without the UI running, the
- #! invalid queue is not initialized and we simply ignore
- #! invalidation requests.
- layout-queue [ push-front notify-ui-thread ] [ drop ] if* ;
-
-DEFER: relayout
-
-: invalidate* ( gadget -- )
- \ invalidate* over (>>layout-state)
- dup forget-pref-dim
- dup gadget-root?
- [ layout-later ] [ parent>> [ relayout ] when* ] if ;
-
-: relayout ( gadget -- )
- dup layout-state>> \ invalidate* eq?
- [ drop ] [ invalidate* ] if ;
-
-: relayout-1 ( gadget -- )
- dup layout-state>>
- [ drop ] [ dup invalidate layout-later ] if ;
-
-: show-gadget ( gadget -- ) t swap (>>visible?) ;
-
-: hide-gadget ( gadget -- ) f swap (>>visible?) ;
-
-DEFER: in-layout?
-
-: do-invalidate ( gadget -- gadget )
- in-layout? get [ dup invalidate ] [ dup invalidate* ] if ;
-
-M: gadget (>>dim) ( dim gadget -- )
- 2dup dim>> =
- [ 2drop ]
- [ tuck call-next-method do-invalidate drop ]
- if ;
-
-GENERIC: pref-dim* ( gadget -- dim )
-
-: ?set-gadget-pref-dim ( dim gadget -- )
- dup layout-state>>
- [ 2drop ] [ (>>pref-dim) ] if ;
-
-: pref-dim ( gadget -- dim )
- dup pref-dim>> [ ] [
- [ pref-dim* dup ] keep ?set-gadget-pref-dim
- ] ?if ;
-
-: pref-dims ( gadgets -- seq ) [ pref-dim ] map ;
-
-M: gadget pref-dim* rect-dim ;
-
-GENERIC: layout* ( gadget -- )
-
-M: gadget layout* drop ;
-
-: prefer ( gadget -- ) dup pref-dim swap (>>dim) ;
-
-: validate ( gadget -- ) f swap (>>layout-state) ;
-
-: layout ( gadget -- )
- dup layout-state>> [
- dup validate
- dup layout*
- dup [ layout ] each-child
- ] when drop ;
-
-: graft-queue ( -- dlist ) \ graft-queue get ;
-
-: unqueue-graft ( gadget -- )
- [ graft-node>> graft-queue delete-node ]
- [ [ first { t t } { f f } ? ] change-graft-state drop ] bi ;
-
-: (queue-graft) ( gadget flags -- )
- >>graft-state
- dup graft-queue push-front* >>graft-node drop
- notify-ui-thread ;
-
-: queue-graft ( gadget -- )
- { f t } (queue-graft) ;
-
-: queue-ungraft ( gadget -- )
- { t f } (queue-graft) ;
-
-: graft-later ( gadget -- )
- dup graft-state>> {
- { { f t } [ drop ] }
- { { t t } [ drop ] }
- { { t f } [ unqueue-graft ] }
- { { f f } [ queue-graft ] }
- } case ;
-
-: ungraft-later ( gadget -- )
- dup graft-state>> {
- { { f f } [ drop ] }
- { { t f } [ drop ] }
- { { f t } [ unqueue-graft ] }
- { { t t } [ queue-ungraft ] }
- } case ;
-
-GENERIC: graft* ( gadget -- )
-
-M: gadget graft* drop ;
-
-: graft ( gadget -- )
- dup graft-later [ graft ] each-child ;
-
-GENERIC: ungraft* ( gadget -- )
-
-M: gadget ungraft* drop ;
-
-: ungraft ( gadget -- )
- dup [ ungraft ] each-child ungraft-later ;
-
-: (unparent) ( gadget -- )
- dup ungraft
- dup forget-pref-dim
- f swap (>>parent) ;
-
-: unfocus-gadget ( child gadget -- )
- tuck focus>> eq?
- [ f swap (>>focus) ] [ drop ] if ;
-
-SYMBOL: in-layout?
-
-: not-in-layout ( -- )
- in-layout? get
- [ "Cannot add/remove gadgets in layout*" throw ] when ;
-
-: unparent ( gadget -- )
- not-in-layout
- [
- dup parent>> dup [
- over (unparent)
- [ unfocus-gadget ] 2keep
- [ children>> delete ] keep
- relayout
- ] [
- 2drop
- ] if
- ] when* ;
-
-: (clear-gadget) ( gadget -- )
- dup [ (unparent) ] each-child
- f over (>>focus)
- f swap (>>children) ;
-
-: clear-gadget ( gadget -- )
- not-in-layout
- dup (clear-gadget) relayout ;
-
-: ((add-gadget)) ( parent child -- parent )
- over children>> ?push >>children ;
-
-: (add-gadget) ( parent child -- parent )
- dup unparent
- over >>parent
- tuck ((add-gadget))
- tuck graft-state>> second
- [ graft ]
- [ drop ]
- if ;
-
-: add-gadget ( parent child -- parent )
- not-in-layout
- (add-gadget)
- dup relayout ;
-
-: add-gadgets ( parent children -- parent )
- not-in-layout
- [ (add-gadget) ] each
- dup relayout ;
-
-: parents ( gadget -- seq )
- [ parent>> ] follow ;
-
-: each-parent ( gadget quot -- ? )
- >r parents r> all? ; inline
-
-: find-parent ( gadget quot -- parent )
- >r parents r> find nip ; inline
-
-: screen-loc ( gadget -- loc )
- parents { 0 0 } [ rect-loc v+ ] reduce ;
-
-: (screen-rect) ( gadget -- loc ext )
- dup parent>> [
- >r rect-extent r> (screen-rect)
- >r tuck v+ r> vmin >r v+ r>
- ] [
- rect-extent
- ] if* ;
-
-: screen-rect ( gadget -- rect )
- (screen-rect) <extent-rect> ;
-
-: child? ( parent child -- ? )
- {
- { [ 2dup eq? ] [ 2drop t ] }
- { [ dup not ] [ 2drop f ] }
- [ parent>> child? ]
- } cond ;
-
-GENERIC: focusable-child* ( gadget -- child/t )
-
-M: gadget focusable-child* drop t ;
-
-: focusable-child ( gadget -- child )
- dup focusable-child*
- dup t eq? [ drop ] [ nip focusable-child ] if ;
-
-GENERIC: request-focus-on ( child gadget -- )
-
-M: gadget request-focus-on parent>> request-focus-on ;
-
-M: f request-focus-on 2drop ;
-
-: request-focus ( gadget -- )
- [ focusable-child ] keep request-focus-on ;
-
-: focus-path ( world -- seq )
- [ focus>> ] follow ;
-
-! Deprecated
-
-: construct-gadget ( class -- tuple )
- >r <gadget> { set-delegate } r> construct ; inline
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets help.markup help.syntax ui.gadgets.grids
-ui.render ;
-IN: ui.gadgets.grid-lines
-
-HELP: grid-lines
-{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $link grid-lines-color } " slot." } ;
+++ /dev/null
-! Copyright (C) 2006, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces opengl opengl.gl sequences
-math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
-IN: ui.gadgets.grid-lines
-
-TUPLE: grid-lines color ;
-
-C: <grid-lines> grid-lines
-
-SYMBOL: grid-dim
-
-: half-gap grid get grid-gap [ 2/ ] map ; inline
-
-: grid-line-from/to ( orientation point -- from to )
- half-gap v-
- [ half-gap spin set-axis ] 2keep
- grid-dim get spin set-axis ;
-
-: draw-grid-lines ( gaps orientation -- )
- grid get rot grid-positions grid get rect-dim suffix [
- grid-line-from/to gl-line
- ] with each ;
-
-M: grid-lines draw-boundary
- origin get [
- -0.5 -0.5 0.0 glTranslated
- grid-lines-color set-color [
- dup grid set
- dup rect-dim half-gap v- grid-dim set
- compute-grid
- { 0 1 } draw-grid-lines
- { 1 0 } draw-grid-lines
- ] with-scope
- ] with-translation ;
+++ /dev/null
-Grid lines visibly separate children of grids and frames
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets help.markup help.syntax arrays ;
-IN: ui.gadgets.grids
-
-ARTICLE: "ui-grid-layout" "Grid layouts"
-"Grid gadgets layout their children in a rectangular grid."
-{ $subsection grid }
-"Creating grids from a fixed set of gadgets:"
-{ $subsection <grid> }
-"Managing chidren:"
-{ $subsection grid-add }
-{ $subsection grid-remove }
-{ $subsection grid-child } ;
-
-HELP: grid
-{ $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height."
-$nl
-"The " { $link grid-gap } " slot stores a pair of integers, the horizontal and vertical gap between children, respectively."
-$nl
-"The " { $link grid-fill? } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
-$nl
-"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "."
-$nl
-"The " { $link add-gadget } ", " { $link unparent } " and " { $link clear-gadget } " words should not be used to manage child gadgets of grids." } ;
-
-HELP: <grid>
-{ $values { "children" "a sequence of sequences of gadgets" } { "grid" "a new " { $link grid } } }
-{ $description "Creates a new " { $link grid } " gadget with the given children." } ;
-
-HELP: grid-child
-{ $values { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } { "gadget" gadget } }
-{ $description "Outputs the child gadget at the " { $snippet "i" } "," { $snippet "j" } "th position of the grid." }
-{ $errors "Throws an error if the indices are out of bounds." } ;
-
-HELP: grid-add
-{ $values { "gadget" gadget } { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
-{ $description "Adds a child gadget at the specified location." }
-{ $side-effects "grid" } ;
-
-HELP: grid-remove
-{ $values { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
-{ $description "Removes a child gadget from the specified location." }
-{ $side-effects "grid" } ;
-
-ABOUT: "ui-grid-layout"
+++ /dev/null
-USING: ui.gadgets ui.gadgets.grids tools.test kernel arrays
-namespaces math.geometry.rect ;
-IN: ui.gadgets.grids.tests
-
-[ { 0 0 } ] [ { } <grid> pref-dim ] unit-test
-
-: 100x100 <gadget> { 100 100 } over set-rect-dim ;
-
-[ { 100 100 } ] [
- 100x100
- 1array 1array <grid> pref-dim
-] unit-test
-
-[ { 100 100 } ] [
- 100x100
- 1array 1array <grid> pref-dim
-] unit-test
-
-[ { 200 100 } ] [
- 100x100
- 100x100
- 2array 1array <grid> pref-dim
-] unit-test
-
-[ { 100 200 } ] [
- 100x100
- 100x100
- [ 1array ] bi@ 2array <grid> pref-dim
-] unit-test
-
-[ ] [
- 100x100
- 100x100
- [ 1array ] bi@ 2array <grid> layout
-] unit-test
-
-[ { 230 120 } { 100 100 } { 100 100 } ] [
- 100x100 dup "a" set
- 100x100 dup "b" set
- 2array 1array <grid>
- { 10 10 } over set-grid-gap
- dup prefer
- dup layout
- rect-dim
- "a" get rect-dim
- "b" get rect-dim
-] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math namespaces sequences words io
-io.streams.string math.vectors ui.gadgets columns accessors
-math.geometry.rect ;
-IN: ui.gadgets.grids
-
-TUPLE: grid < gadget
-grid
-{ gap initial: { 0 0 } }
-{ fill? initial: t } ;
-
-: new-grid ( children class -- grid )
- new-gadget
- [ (>>grid) ] [ >r concat r> swap add-gadgets drop ] [ nip ] 2tri ;
- inline
-
-: <grid> ( children -- grid )
- grid new-grid ;
-
-: grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
-
-: grid-add ( grid child i j -- grid )
- >r >r dupd swap r> r>
- >r >r 2dup swap add-gadget drop r> r>
- 3dup grid-child unparent rot grid>> nth set-nth ;
-
-: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add ;
-
-: pref-dim-grid ( grid -- dims )
- grid>> [ [ pref-dim ] map ] map ;
-
-: (compute-grid) ( grid -- seq ) [ max-dim ] map ;
-
-: compute-grid ( grid -- horiz vert )
- pref-dim-grid dup flip (compute-grid) swap (compute-grid) ;
-
-: (pair-up) ( horiz vert -- dim )
- >r first r> second 2array ;
-
-: pair-up ( horiz vert -- dims )
- [ [ (pair-up) ] curry map ] with map ;
-
-: add-gaps ( gap seq -- newseq )
- [ v+ ] with map ;
-
-: gap-sum ( gap seq -- newseq )
- dupd add-gaps dim-sum v+ ;
-
-M: grid pref-dim*
- dup grid-gap swap compute-grid >r over r>
- gap-sum >r gap-sum r> (pair-up) ;
-
-: do-grid ( dims grid quot -- )
- -rot grid>>
- [ [ pick call ] 2each ] 2each
- drop ; inline
-
-: grid-positions ( grid dims -- locs )
- >r grid-gap dup r> add-gaps swap [ v+ ] accumulate nip ;
-
-: position-grid ( grid horiz vert -- )
- pick >r
- >r over r> grid-positions >r grid-positions r>
- pair-up r> [ set-rect-loc ] do-grid ;
-
-: resize-grid ( grid horiz vert -- )
- pick grid-fill? [
- pair-up swap [ (>>dim) ] do-grid
- ] [
- 2drop grid>> [ [ prefer ] each ] each
- ] if ;
-
-: grid-layout ( grid horiz vert -- )
- [ position-grid ] 3keep resize-grid ;
-
-M: grid layout* dup compute-grid grid-layout ;
-
-M: grid children-on ( rect gadget -- seq )
- dup gadget-children empty? [
- 2drop f
- ] [
- { 0 1 } swap grid>>
- [ 0 <column> fast-children-on ] keep
- <slice> concat
- ] if ;
-
-M: grid gadget-text*
- grid>>
- [ [ gadget-text ] map ] map format-table
- [ CHAR: \n , ] [ % ] interleave ;
+++ /dev/null
-Grids arrange children in a variable-size grid
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel assocs ui.gestures ui.gadgets.wrappers accessors ;
-
-IN: ui.gadgets.handler
-
-TUPLE: handler < wrapper table ;
-
-: <handler> ( child -- handler ) handler new-wrapper ;
-
-M: handler handle-gesture* ( gadget gesture delegate -- ? )
- table>> at dup [ call f ] [ 2drop t ] if ;
\ No newline at end of file
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets help.markup help.syntax ui.gadgets.packs ;
-IN: ui.gadgets.incremental
-
-HELP: incremental
-{ $class-description "Incremental layout gadgets inherit from " { $link pack } " and implement an optimization where the relayout operation after adding a child to be done in constant time."
-$nl
-"Incremental layout gadgets are created by calling " { $link <incremental> } "."
-$nl
-"Children are managed with the " { $link add-incremental } " and " { $link clear-incremental } " words."
-$nl
-"Not every " { $link pack } " can use incremental layout, since incremental layout does not support non-default values for " { $link pack-align } ", " { $link pack-fill } ", and " { $link pack-gap } "." } ;
-
-HELP: <incremental>
-{ $values { "pack" pack } { "incremental" "a new instance of " { $link incremental } } }
-{ $description "Creates a new incremental layout gadget delegating to " { $snippet "pack" } "." } ;
-
-{ <incremental> add-incremental clear-incremental } related-words
-
-HELP: add-incremental
-{ $values { "gadget" gadget } { "incremental" incremental } }
-{ $description "Adds the gadget to the incremental layout and performs relayout immediately in constant time." }
-{ $side-effects "incremental" } ;
-
-HELP: clear-incremental
-{ $values { "incremental" incremental } }
-{ $description "Removes all gadgets from the incremental layout and performs relayout immediately in constant time." }
-{ $side-effects "incremental" } ;
-
-ARTICLE: "ui-incremental-layout" "Incremental layouts"
-"Incremental layout gadgets are like " { $link "ui-pack-layout" } " except the relayout operation after adding a new child can be done in constant time."
-$nl
-"With all layouts, relayout requests from consecutive additions and removals are of children are coalesced and result in only one relayout operation being performed, however the run time of the relayout operation itself depends on the number of children."
-$nl
-"Incremental layout is used by " { $link "ui.gadgets.panes" } " to ensure that new lines of output does not take longer to display when the pane already has previous output."
-$nl
-"Incremental layouts are not a general replacement for " { $link "ui-pack-layout" } " and there are some limitations to be aware of."
-{ $subsection incremental }
-{ $subsection <incremental> }
-"Children are added and removed with a special set of words which perform necessary relayout immediately:"
-{ $subsection add-incremental }
-{ $subsection clear-incremental }
-"Calling " { $link unparent } " to remove a child of an incremental layout is permitted, however the relayout following the removal will not be performed in constant time, because all gadgets following the removed gadget need to be moved." ;
-
-ABOUT: "ui-incremental-layout"
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io kernel math namespaces math.vectors ui.gadgets
-ui.gadgets.packs accessors math.geometry.rect ;
-IN: ui.gadgets.incremental
-
-! Incremental layout allows adding lines to panes to be O(1).
-! Note that incremental packs are distinct from ordinary packs
-! defined in layouts.factor, since you don't want all packs to
-! be incremental. In particular, incremental packs do not
-! support non-default values for pack-align, pack-fill and
-! pack-gap.
-
-! The cursor is the current size of the incremental pack.
-! New gadgets are added at
-! incremental-cursor gadget-orientation v*
-
-TUPLE: incremental < pack cursor ;
-
-: <incremental> ( -- incremental )
- incremental new-gadget
- { 0 1 } >>orientation
- { 0 0 } >>cursor ;
-
-M: incremental pref-dim*
- dup gadget-layout-state [
- dup call-next-method over set-incremental-cursor
- ] when incremental-cursor ;
-
-: next-cursor ( gadget incremental -- cursor )
- [
- swap rect-dim swap incremental-cursor
- 2dup v+ >r vmax r>
- ] keep gadget-orientation set-axis ;
-
-: update-cursor ( gadget incremental -- )
- [ next-cursor ] keep set-incremental-cursor ;
-
-: incremental-loc ( gadget incremental -- )
- dup incremental-cursor swap gadget-orientation v*
- swap set-rect-loc ;
-
-: prefer-incremental ( gadget -- )
- dup forget-pref-dim dup pref-dim swap set-rect-dim ;
-
-: add-incremental ( gadget incremental -- )
- not-in-layout
- 2dup swap (add-gadget) drop
- over prefer-incremental
- over layout-later
- 2dup incremental-loc
- tuck update-cursor
- dup prefer-incremental
- gadget-parent [ invalidate* ] when* ;
-
-: clear-incremental ( incremental -- )
- not-in-layout
- dup (clear-gadget)
- dup forget-pref-dim
- { 0 0 } over set-incremental-cursor
- gadget-parent [ relayout ] when* ;
+++ /dev/null
-Children can be added to incremental layouts in constant time
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets help.markup help.syntax strings models
-ui.gadgets.panes ;
-IN: ui.gadgets.labelled
-
-HELP: labelled-gadget
-{ $class-description "A labelled gadget can be created by calling " { $link <labelled-gadget> } "." } ;
-
-HELP: <labelled-gadget>
-{ $values { "gadget" gadget } { "title" string } { "newgadget" "a new " { $link <labelled-gadget> } } }
-{ $description "Creates a new " { $link labelled-gadget } " display " { $snippet "gadget" } " with " { $snippet "title" } " on top." } ;
-
-HELP: closable-gadget
-{ $class-description "A closable gadget displays a title bar with a close box on top of another gadget. Clicking the close box invokes a quotation. Closable gadgets are created by calling " { $link <closable-gadget> } "." } ;
-
-HELP: <closable-gadget>
-{ $values { "gadget" gadget } { "title" string } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } }
-{ $description "Creates a new " { $link closable-gadget } ". Clicking the close box calls " { $snippet "quot" } "." }
-{ $notes "The quotation can find the " { $link closable-gadget } " instance, or any other parent gadget by calling " { $link find-parent } " with the gadget it receives on the stack." } ;
-
-HELP: <labelled-pane>
-{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "scrolls?" "a boolean" } { "title" string } { "gadget" "a new " { $link gadget } } }
-{ $description "Creates a new control delegating to a " { $link pane } ", and wraps it in a " { $link labelled-gadget } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
-
-{ <labelled-pane> <pane-control> } related-words
-
-ARTICLE: "ui.gadgets.labelled" "Labelled gadgets"
-"It is possible to create a labelled border around a child gadget:"
-{ $subsection labelled-gadget }
-{ $subsection <labelled-gadget> }
-"Or a labelled border with a close box:"
-{ $subsection closable-gadget }
-{ $subsection <closable-gadget> } ;
-
-ABOUT: "ui.gadgets.labelled"
+++ /dev/null
-! Copyright (C) 2006, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ui.gadgets.buttons ui.gadgets.borders
-ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
-ui.gadgets.tracks ui.gadgets.theme ui.gadgets.frames
-ui.gadgets.grids io kernel math models namespaces prettyprint
-sequences sequences words classes.tuple ui.gadgets ui.render
-colors accessors ;
-IN: ui.gadgets.labelled
-
-TUPLE: labelled-gadget < track content ;
-
-: <labelled-gadget> ( gadget title -- newgadget )
- { 0 1 } labelled-gadget new-track
- swap <label> reverse-video-theme f track-add
- swap >>content
- dup content>> 1 track-add ;
-
-M: labelled-gadget focusable-child* labelled-gadget-content ;
-
-: <labelled-scroller> ( gadget title -- gadget )
- >r <scroller> r> <labelled-gadget> ;
-
-: <labelled-pane> ( model quot scrolls? title -- gadget )
- >r >r <pane-control> r> over set-pane-scrolls? r>
- <labelled-scroller> ;
-
-: <close-box> ( quot -- button/f )
- gray close-box <polygon-gadget> swap <bevel-button> ;
-
-: title-theme ( gadget -- )
- { 1 0 } over set-gadget-orientation
- T{ gradient f {
- T{ rgba f 0.65 0.65 1.0 1.0 }
- T{ rgba f 0.65 0.45 1.0 1.0 }
- } } swap set-gadget-interior ;
-
-: <title-label> ( text -- label ) <label> dup title-theme ;
-
-: <title-bar> ( title quot -- gadget )
- <frame>
- swap dup [ <close-box> @left grid-add ] [ drop ] if
- swap <title-label> @center grid-add ;
-
-TUPLE: closable-gadget < frame content ;
-
-: find-closable-gadget ( parent -- child )
- [ [ closable-gadget? ] is? ] find-parent ;
-
-: <closable-gadget> ( gadget title quot -- gadget )
- closable-gadget new-frame
- -rot <title-bar> @top grid-add
- swap >>content
- dup content>> @center grid-add ;
-
-M: closable-gadget focusable-child* closable-gadget-content ;
+++ /dev/null
-Labelled gadgets display a border with a text label surrounding a child
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax strings ui.gadgets models ;
-IN: ui.gadgets.labels
-
-HELP: label
-{ $class-description "A label displays a piece of text, either a single line string or an array of line strings. Labels are created by calling " { $link <label> } "." } ;
-
-HELP: <label>
-{ $values { "string" string } { "label" "a new " { $link label } } }
-{ $description "Creates a new " { $link label } " gadget. The string is permitted to contain line breaks." } ;
-
-HELP: label-string
-{ $values { "label" label } { "string" string } }
-{ $description "Outputs the string currently displayed by the label." } ;
-
-HELP: set-label-string
-{ $values { "label" label } { "string" string } }
-{ $description "Sets the string currently displayed by the label. The string is permitted to contain line breaks. After calling this word, you must also call " { $link relayout } " on the label." } ;
-
-HELP: <label-control>
-{ $values { "model" model } { "gadget" "a new " { $link gadget } } }
-{ $description "Creates a control which displays the value of " { $snippet "model" } ", which is required to be a string. The label control is automatically updated when the model value changes." } ;
-
-{ label-string set-label-string } related-words
-{ <label> <label-control> } related-words
-
-ARTICLE: "ui.gadgets.labels" "Label gadgets"
-"A label displays a piece of text, either a single line string or an array of line strings."
-{ $subsection label }
-{ $subsection <label> }
-{ $subsection <label-control> }
-{ $subsection label-string }
-{ $subsection set-label-string }
-"Label specifiers are used by buttons, checkboxes and radio buttons:"
-{ $subsection >label } ;
-
-ABOUT: "ui.gadgets.labels"
-
-HELP: >label
-{ $values { "obj" "a label specifier" } { "gadget" "a new " { $link gadget } } }
-{ $description "Convert the object into a gadget suitable for use as the label of a button. If " { $snippet "obj" } " is already a gadget, does nothing. Otherwise creates a " { $link label } " gadget if it is a string and an empty gadget if " { $snippet "obj" } " is " { $link f } "." } ;
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays hashtables io kernel math namespaces
-opengl sequences strings splitting
-ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors
-models ;
-IN: ui.gadgets.labels
-
-! A label gadget draws a string.
-TUPLE: label < gadget text font color ;
-
-: label-string ( label -- string )
- text>> dup string? [ "\n" join ] unless ; inline
-
-: set-label-string ( string label -- )
- CHAR: \n pick memq? [
- >r string-lines r> set-label-text
- ] [
- set-label-text
- ] if ; inline
-
-: label-theme ( gadget -- gadget )
- sans-serif-font >>font
- black >>color ; inline
-
-: new-label ( string class -- label )
- new-gadget
- [ set-label-string ] keep
- label-theme ; inline
-
-: <label> ( string -- label )
- label new-label ;
-
-M: label pref-dim*
- [ font>> open-font ] [ text>> ] bi text-dim ;
-
-M: label draw-gadget*
- [ color>> set-color ]
- [ [ font>> ] [ text>> ] bi origin get draw-text ] bi ;
-
-M: label gadget-text* label-string % ;
-
-TUPLE: label-control < label ;
-
-M: label-control model-changed
- swap model-value over set-label-string relayout ;
-
-: <label-control> ( model -- gadget )
- "" label-control new-label
- swap >>model ;
-
-: text-theme ( gadget -- gadget )
- black >>color
- monospace-font >>font ;
-
-: reverse-video-theme ( label -- label )
- white >>color
- black solid-interior ;
-
-GENERIC: >label ( obj -- gadget )
-M: string >label <label> ;
-M: array >label <label> ;
-M: object >label ;
-M: f >label drop <gadget> ;
-
-: label-on-left ( gadget label -- button )
- { 1 0 } <track>
- swap >label f track-add
- swap 1 track-add ;
-
-: label-on-right ( label gadget -- button )
- { 1 0 } <track>
- swap f track-add
- swap >label 1 track-add ;
+++ /dev/null
-Label gadgets display one or more lines of text with a single font and color
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: ui.backend ui.gadgets.worlds ;
-
-IN: ui.gadgets.lib
-
-: find-gl-context ( gadget -- ) find-world world-handle select-gl-context ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.commands help.markup help.syntax ui.gadgets
-ui.gadgets.presentations ui.operations kernel models classes ;
-IN: ui.gadgets.lists
-
-HELP: +secondary+
-{ $description "A key which may be set in the hashtable passed to " { $link define-operation } ". If set to a true value, this operation becomes the default operation performed when " { $snippet "RET" } " is pressed in a " { $link list } " gadget where the current selection is a presentation matching the operation's predicate." } ;
-
-HELP: list
-{ $class-description
- "A list control is backed by a " { $link model } " holding a sequence of objects, and displays as a list of " { $link presentation } " instances of these objects."
- $nl
- "Lists are created by calling " { $link <list> } "."
- { $command-map list "keyboard-navigation" }
-} ;
-
-HELP: <list>
-{ $values { "hook" "a quotation with stack effect " { $snippet "( list -- )" } } { "presenter" "a quotation with stack effect " { $snippet "( object -- label )" } } { "model" model } { "gadget" list } }
-{ $description "Creates a new " { $link list } "."
-$nl
-"The model value must be a sequence. The list displays presentations of elements with labels obtained by applying the " { $snippet "presenter" } " quotation to each object. The " { $snippet "hook" } " quotation is called when a presentation is selected." } ;
-
-HELP: list-value
-{ $values { "list" list } { "object" object } }
-{ $description "Outputs the currently selected list value." } ;
-
-ARTICLE: "ui.gadgets.lists" "List gadgets"
-"A list displays a list of presentations."
-{ $subsection list }
-{ $subsection <list> }
-{ $subsection list-value } ;
-
-ABOUT: "ui.gadgets.lists"
+++ /dev/null
-IN: ui.gadgets.lists.tests
-USING: ui.gadgets.lists models prettyprint math tools.test
-kernel ;
-
-[ ] [ [ drop ] [ 3 + . ] f <model> <list> invoke-value-action ] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ui.commands ui.gestures ui.render ui.gadgets
-ui.gadgets.labels ui.gadgets.scrollers
-kernel sequences models opengl math math.order namespaces
-ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
-math.vectors classes.tuple math.geometry.rect colors ;
-
-IN: ui.gadgets.lists
-
-TUPLE: list < pack index presenter color hook ;
-
-: list-theme ( list -- list )
- T{ rgba f 0.8 0.8 1.0 1.0 } >>color ; inline
-
-: <list> ( hook presenter model -- gadget )
- list new-gadget
- { 0 1 } >>orientation
- 1 >>fill
- 0 >>index
- swap >>model
- swap >>presenter
- swap >>hook
- list-theme ;
-
-: calc-bounded-index ( n list -- m )
- control-value length 1- min 0 max ;
-
-: bound-index ( list -- )
- dup list-index over calc-bounded-index
- swap set-list-index ;
-
-: list-presentation-hook ( list -- quot )
- hook>> [ [ [ list? ] is? ] find-parent ] prepend ;
-
-: <list-presentation> ( hook elt presenter -- gadget )
- keep >r >label text-theme r>
- <presentation>
- swap >>hook ; inline
-
-: <list-items> ( list -- seq )
- [ list-presentation-hook ]
- [ presenter>> ]
- [ control-value ]
- tri [
- >r 2dup r> swap <list-presentation>
- ] map 2nip ;
-
-M: list model-changed
- nip
- dup clear-gadget
- dup <list-items> over swap add-gadgets drop
- bound-index ;
-
-: selected-rect ( list -- rect )
- dup list-index swap gadget-children ?nth ;
-
-M: list draw-gadget*
- origin get [
- dup list-color set-color
- selected-rect [ rect-extent gl-fill-rect ] when*
- ] with-translation ;
-
-M: list focusable-child* drop t ;
-
-: list-value ( list -- object )
- dup list-index swap control-value ?nth ;
-
-: scroll>selected ( list -- )
- #! We change the rectangle's width to zero to avoid
- #! scrolling right.
- [ selected-rect rect-bounds { 0 1 } v* <rect> ] keep
- scroll>rect ;
-
-: list-empty? ( list -- ? ) control-value empty? ;
-
-: select-index ( n list -- )
- dup list-empty? [
- 2drop
- ] [
- [ control-value length rem ] keep
- [ set-list-index ] keep
- [ relayout-1 ] keep
- scroll>selected
- ] if ;
-
-: select-previous ( list -- )
- dup list-index 1- swap select-index ;
-
-: select-next ( list -- )
- dup list-index 1+ swap select-index ;
-
-: invoke-value-action ( list -- )
- dup list-empty? [
- dup list-hook call
- ] [
- dup list-index swap nth-gadget invoke-secondary
- ] if ;
-
-: select-gadget ( gadget list -- )
- swap over gadget-children index
- [ swap select-index ] [ drop ] if* ;
-
-: clamp-loc ( point max -- point )
- vmin { 0 0 } vmax ;
-
-: select-at ( point list -- )
- [ rect-dim clamp-loc ] keep
- [ pick-up ] keep
- select-gadget ;
-
-: list-page ( list vec -- )
- >r dup selected-rect rect-bounds 2 v/n v+
- over visible-dim r> v* v+ swap select-at ;
-
-: list-page-up ( list -- ) { 0 -1 } list-page ;
-
-: list-page-down ( list -- ) { 0 1 } list-page ;
-
-list "keyboard-navigation" "Lists can be navigated from the keyboard." {
- { T{ button-down } request-focus }
- { T{ key-down f f "UP" } select-previous }
- { T{ key-down f f "DOWN" } select-next }
- { T{ key-down f f "PAGE_UP" } list-page-up }
- { T{ key-down f f "PAGE_DOWN" } list-page-down }
- { T{ key-down f f "RET" } invoke-value-action }
-} define-command-map
+++ /dev/null
-List gadgets display a keyboard-navigatable list of presentations
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets help.markup help.syntax ui.gadgets.worlds
-kernel ;
-IN: ui.gadgets.menus
-
-HELP: <commands-menu>
-{ $values { "hook" "a quotation with stack effect " { $snippet "( button -- )" } } { "target" object } { "commands" "a sequence of commands" } { "gadget" "a new " { $link gadget } } }
-{ $description "Creates a popup menu of commands which are to be invoked on " { $snippet "target" } ". The " { $snippet "hook" } " quotation is run before a command is invoked." } ;
-
-HELP: show-menu
-{ $values { "gadget" gadget } { "owner" gadget } }
-{ $description "Displays a popup menu in the " { $link world } " containing " { $snippet "owner" } " at the current mouse location." } ;
+++ /dev/null
-! Copyright (C) 2005, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ui.commands ui.gadgets ui.gadgets.buttons
-ui.gadgets.worlds ui.gestures generic hashtables kernel math
-models namespaces opengl sequences math.vectors
-ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors
-math.geometry.rect ;
-IN: ui.gadgets.menus
-
-: menu-loc ( world menu -- loc )
- >r rect-dim r> pref-dim [v-] hand-loc get-global vmin ;
-
-TUPLE: menu-glass < gadget ;
-
-: <menu-glass> ( menu world -- glass )
- menu-glass new-gadget
- >r over menu-loc over set-rect-loc r>
- [ swap add-gadget drop ] keep ;
-
-M: menu-glass layout* gadget-child prefer ;
-
-: hide-glass ( world -- )
- dup world-glass [ unparent ] when*
- f swap set-world-glass ;
-
-: show-glass ( gadget world -- )
- over hand-clicked set-global
- [ hide-glass ] keep
- [ swap add-gadget drop ] 2keep
- set-world-glass ;
-
-: show-menu ( gadget owner -- )
- find-world [ <menu-glass> ] keep show-glass ;
-
-\ menu-glass H{
- { T{ button-down } [ find-world [ hide-glass ] when* ] }
- { T{ drag } [ update-clicked drop ] }
-} set-gestures
-
-: <menu-item> ( hook target command -- button )
- dup command-name -rot command-button-quot
- swapd
- [ hand-clicked get find-world hide-glass ]
- 3append <roll-button> ;
-
-: menu-theme ( gadget -- gadget )
- light-gray solid-interior
- faint-boundary ;
-
-: <commands-menu> ( hook target commands -- gadget )
- <filled-pile>
- -roll
- [ <menu-item> add-gadget ] with with each
- 5 <border> menu-theme ;
+++ /dev/null
-Menu gadgets pop up as a list of commands at the mouse location
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets help.markup help.syntax generic kernel
-classes.tuple quotations ;
-IN: ui.gadgets.packs
-
-ARTICLE: "ui-pack-layout" "Pack layouts"
-"Pack gadgets layout their children along a single axis."
-{ $subsection pack }
-"Creating empty packs:"
-{ $subsection <pack> }
-{ $subsection <pile> }
-{ $subsection <shelf> }
-
-"For more control, custom layouts can reuse portions of pack layout logic:"
-{ $subsection pack-pref-dim }
-{ $subsection pack-layout } ;
-
-HELP: pack
-{ $class-description "A gadget which lays out its children along a single axis stored in the " { $link gadget-orientation } " slot. Can be constructed with one of the following words:"
-{ $list
- { $link <pack> }
- { $link <pile> }
- { $link <shelf> }
-}
-"Packs have the following slots:"
-{ $list
- { { $link pack-align } " a rational number between 0 and 1, the alignment of gadgets along the axis perpendicular to the pack's orientation" }
- { { $link pack-fill } " a rational number between 0 and 1, where 0 gives each gadget its preferred size and 1 fills the dimension perpendicular to the pack's orientation" }
- { { $link pack-gap } " a pair of integers, the horizontal and vertical gap between children" }
-}
-"Custom gadgets can inherit from the " { $link pack } " class and implement their own " { $link pref-dim* } " and " { $link layout* } " methods, reusing pack layout logic by calling " { $link pack-pref-dim } " and " { $link pack-layout } "." } ;
-
-HELP: pack-layout
-{ $values { "pack" "a new " { $link pack } } { "sizes" "a sequence of pairs of integers" } }
-{ $description "Lays out the pack's children along the " { $link gadget-orientation } " of the pack, with each gadget receiving its size from the corresponding index of the " { $snippet "sizes" } " sequence." }
-{ $notes
- "This word is useful if you are writing your own layout gadget which inherits from " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
-} ;
-
-HELP: <pack>
-{ $values { "orientation" "an orientation specifier" } { "pack" "a new " { $link pack } } }
-{ $description "Creates a new pack which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
-
-{ <pack> <pile> <shelf> } related-words
-
-HELP: <pile>
-{ $values { "pack" "a new " { $link pack } } }
-{ $description "Creates a new " { $link pack } " which lays out its children vertically." } ;
-
-HELP: <shelf>
-{ $values { "pack" "a new " { $link pack } } }
-{ $description "Creates a new " { $link pack } " which lays out its children horizontally." } ;
-
-HELP: pack-pref-dim
-{ $values { "gadget" gadget } { "sizes" "a sequence of pairs of integers" } { "dim" "a pair of integers" } }
-{ $description "Computes the preferred size of a pack, with each gadget receiving its size from the corresponding index of the " { $snippet "sizes" } " sequence." }
-{ $notes
- "This word is useful if you are writing your own layout gadget which inherits from " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
-} ;
-
-ABOUT: "ui-pack-layout"
+++ /dev/null
-IN: ui.gadgets.packs.tests
-USING: ui.gadgets.packs ui.gadgets.labels ui.gadgets ui.render
-kernel namespaces tools.test math.parser sequences math.geometry.rect ;
-
-[ t ] [
- { 0 0 } { 100 100 } <rect> clip set
-
- <pile>
- 100 [ number>string <label> add-gadget ] each
- dup layout
-
- visible-children [ label? ] all?
-] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: sequences ui.gadgets kernel math math.functions
-math.vectors namespaces math.order accessors math.geometry.rect ;
-IN: ui.gadgets.packs
-
-TUPLE: pack < gadget
-{ align initial: 0 }
-{ fill initial: 0 }
-{ gap initial: { 0 0 } } ;
-
-: packed-dim-2 ( gadget sizes -- list )
- [ over rect-dim over v- rot pack-fill v*n v+ ] with map ;
-
-: packed-dims ( gadget sizes -- seq )
- 2dup packed-dim-2 swap orient ;
-
-: gap-locs ( gap sizes -- seq )
- { 0 0 } [ v+ over v+ ] accumulate 2nip ;
-
-: aligned-locs ( gadget sizes -- seq )
- [ >r dup pack-align swap rect-dim r> v- n*v ] with map ;
-
-: packed-locs ( gadget sizes -- seq )
- over pack-gap over gap-locs >r dupd aligned-locs r> orient ;
-
-: round-dims ( seq -- newseq )
- { 0 0 } swap
- [ swap v- dup [ ceiling >fixnum ] map [ swap v- ] keep ] map
- nip ;
-
-: pack-layout ( pack sizes -- )
- round-dims over gadget-children
- >r dupd packed-dims r> 2dup [ (>>dim) ] 2each
- >r packed-locs r> [ set-rect-loc ] 2each ;
-
-: <pack> ( orientation -- pack )
- pack new-gadget
- swap >>orientation ;
-
-: <pile> ( -- pack ) { 0 1 } <pack> ;
-
-: <filled-pile> ( -- pack ) <pile> 1 over set-pack-fill ;
-
-: <shelf> ( -- pack ) { 1 0 } <pack> ;
-
-: gap-dims ( gap sizes -- seeq )
- [ dim-sum ] keep length 1 [-] rot n*v v+ ;
-
-: pack-pref-dim ( gadget sizes -- dim )
- over pack-gap over gap-dims >r max-dim r>
- rot gadget-orientation set-axis ;
-
-M: pack pref-dim*
- dup gadget-children pref-dims pack-pref-dim ;
-
-M: pack layout*
- dup gadget-children pref-dims pack-layout ;
-
-M: pack children-on ( rect gadget -- seq )
- dup gadget-orientation swap gadget-children
- [ fast-children-on ] keep <slice> ;
+++ /dev/null
-Pack gadgets arrange children horizontally or vertically
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets models help.markup help.syntax io kernel
-quotations ;
-IN: ui.gadgets.panes
-
-HELP: pane
-{ $class-description "A pane " { $link gadget } " displays formatted text which is written to a " { $link pane-stream } " targetting the pane. Panes are created by calling " { $link <pane> } ", " { $link <scrolling-pane> } " or " { $link <pane-control> } "." } ;
-
-HELP: <pane>
-{ $values { "pane" "a new " { $link pane } } }
-{ $description "Creates a new " { $link pane } " gadget." } ;
-
-HELP: write-gadget
-{ $values { "gadget" gadget } { "stream" "an output stream" } }
-{ $contract "Writes a gadget to the stream." }
-{ $notes "Not all streams support this operation." } ;
-
-{ write-gadget print-gadget gadget. } related-words
-
-HELP: print-gadget
-{ $values { "gadget" gadget } { "stream" "an output stream" } }
-{ $description "Writes a gadget to the stream, followed by a newline." }
-{ $notes "Not all streams support this operation." } ;
-
-HELP: gadget.
-{ $values { "gadget" gadget } }
-{ $description "Writes a gadget followed by a newline to " { $link output-stream } "." }
-{ $notes "Not all streams support this operation." } ;
-
-HELP: ?nl
-{ $values { "stream" pane-stream } }
-{ $description "Inserts a line break in the pane unless the current line is empty." } ;
-
-HELP: with-pane
-{ $values { "pane" pane } { "quot" quotation } }
-{ $description "Clears the pane and calls the quotation in a new scope where " { $link output-stream } " is rebound to a " { $link pane-stream } " writing to the pane." } ;
-
-HELP: make-pane
-{ $values { "quot" quotation } { "gadget" "a new " { $link gadget } } }
-{ $description "Calls the quotation in a new scope where " { $link output-stream } " is rebound to a " { $link pane-stream } " writing to a new pane. The output area of the new pane is output on the stack after the quotation returns. The pane itself is not output." } ;
-
-HELP: <scrolling-pane>
-{ $values { "pane" "a new " { $link pane } } }
-{ $description "Creates a new " { $link pane } " gadget which scrolls any scroll pane containing it to the bottom on output. behaving much like a terminal or logger." } ;
-
-HELP: <pane-control>
-{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "pane" "a new " { $link pane } } }
-{ $description "Creates a new control delegating to a " { $link pane } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
-
-HELP: pane-stream
-{ $class-description "Pane streams implement the portion of the " { $link "stream-protocol" } " responsible for output of text, including full support for " { $link "styles" } ". Pane streams also support direct output of gadgets via " { $link write-gadget } " and " { $link print-gadget } ". Pane streams are created by calling " { $link <pane-stream> } "." } ;
-
-HELP: <pane-stream> ( pane -- stream )
-{ $values { "pane" pane } { "stream" "a new " { $link pane-stream } } }
-{ $description "Creates a new " { $link pane-stream } " for writing to " { $snippet "pane" } "." } ;
-
-{ with-pane make-pane } related-words
-
-ARTICLE: "ui.gadgets.panes" "Pane gadgets"
-"A pane displays formatted text."
-{ $subsection pane }
-{ $subsection <pane> }
-{ $subsection <scrolling-pane> }
-{ $subsection <pane-control> }
-"Panes are written to by creating a special output stream:"
-{ $subsection pane-stream }
-{ $subsection <pane-stream> }
-"In addition to the stream output words (" { $link "stream-protocol" } ", pane streams can have gadgets written to them:"
-{ $subsection write-gadget }
-{ $subsection print-gadget }
-{ $subsection gadget. }
-"The " { $link gadget. } " word is useful for interactive debugging of gadgets in the listener."
-$nl
-"There are a few combinators for working with panes:"
-{ $subsection with-pane }
-{ $subsection make-pane } ;
-
-ABOUT: "ui.gadgets.panes"
+++ /dev/null
-IN: ui.gadgets.panes.tests
-USING: alien ui.gadgets.panes ui.gadgets namespaces
-kernel sequences io io.styles io.streams.string tools.test
-prettyprint definitions help help.syntax help.markup
-help.stylesheet splitting tools.test.ui models math summary
-inspector ;
-
-: #children "pane" get gadget-children length ;
-
-[ ] [ <pane> "pane" set ] unit-test
-
-[ ] [ #children "num-children" set ] unit-test
-
-[ ] [
- "pane" get <pane-stream> [ 10000 [ . ] each ] with-output-stream*
-] unit-test
-
-[ t ] [ #children "num-children" get = ] unit-test
-
-: test-gadget-text
- dup make-pane gadget-text dup print "======" print
- swap with-string-writer dup print "\n" ?tail drop "\n" ?tail drop = ;
-
-[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
-[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
-[ t ] [
- [
- H{ { wrap-margin 100 } } [ "hello" pprint ] with-nesting
- ] test-gadget-text
-] unit-test
-[ t ] [
- [
- H{ { wrap-margin 100 } } [
- H{ } [
- "hello" pprint
- ] with-style
- ] with-nesting
- ] test-gadget-text
-] unit-test
-[ t ] [ [ [ 1 2 3 ] pprint ] test-gadget-text ] unit-test
-[ t ] [ [ \ + describe ] test-gadget-text ] unit-test
-[ t ] [ [ \ = see ] test-gadget-text ] unit-test
-[ t ] [ [ \ = help ] test-gadget-text ] unit-test
-
-[ t ] [
- [
- title-style get [
- "Hello world" write
- ] with-style
- ] test-gadget-text
-] unit-test
-
-
-[ t ] [
- [
- title-style get [
- "Hello world" write
- ] with-nesting
- ] test-gadget-text
-] unit-test
-
-[ t ] [
- [
- title-style get [
- title-style get [
- "Hello world" write
- ] with-nesting
- ] with-style
- ] test-gadget-text
-] unit-test
-
-[ t ] [
- [
- title-style get [
- title-style get [
- [ "Hello world" write ] ($block)
- ] with-nesting
- ] with-style
- ] test-gadget-text
-] unit-test
-
-ARTICLE: "test-article-1" "This is a test article"
-"Hello world, how are you today." ;
-
-[ t ] [ [ "test-article-1" $title ] test-gadget-text ] unit-test
-
-[ t ] [ [ "test-article-1" help ] test-gadget-text ] unit-test
-
-ARTICLE: "test-article-2" "This is a test article"
-"Hello world, how are you today."
-{ $table { "a" "b" } { "c" "d" } } ;
-
-[ t ] [ [ "test-article-2" help ] test-gadget-text ] unit-test
-
-<pane> [ \ = see ] with-pane
-<pane> [ \ = help ] with-pane
-
-[ ] [
- \ = <model> [ see ] <pane-control> [ ] with-grafted-gadget
-] unit-test
+++ /dev/null
-! 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 ;
-
-IN: ui.gadgets.panes
-
-TUPLE: pane < pack
- output current prototype scrolls?
- selection-color caret mark selecting? ;
-
-: clear-selection ( pane -- pane ) f >>caret f >>mark ;
-
-: add-output ( pane current -- pane ) [ >>output ] [ add-gadget ] bi ;
-: add-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ;
-
-: prepare-line ( pane -- pane )
- clear-selection
- dup prototype>> clone add-current ;
-
-: 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 ( pane -- string/f ) selected-children gadget-text ;
-
-: pane-clear ( pane -- )
- clear-selection
- [ pane-output clear-incremental ]
- [ pane-current clear-gadget ]
- bi ;
-
-: new-pane ( class -- pane )
- new-gadget
- { 0 1 } >>orientation
- <shelf> >>prototype
- <incremental> add-output
- prepare-line
- selection-color >>selection-color ;
-
-: <pane> ( -- pane ) pane new-pane ;
-
-GENERIC: draw-selection ( loc obj -- )
-
-: if-fits ( rect quot -- )
- >r clip get over intersects? r> [ drop ] if ; inline
-
-M: gadget draw-selection ( loc gadget -- )
- swap offset-rect [ rect-extent gl-fill-rect ] if-fits ;
-
-M: node draw-selection ( loc node -- )
- 2dup node-value swap offset-rect [
- drop 2dup
- [ node-value rect-loc v+ ] keep
- node-children [ draw-selection ] with each
- ] if-fits 2drop ;
-
-M: pane draw-gadget*
- dup gadget-selection? [
- dup pane-selection-color set-color
- origin get over rect-loc v- swap selected-children
- [ draw-selection ] with each
- ] [
- drop
- ] if ;
-
-: scroll-pane ( pane -- )
- dup pane-scrolls? [ scroll>bottom ] [ drop ] if ;
-
-TUPLE: pane-stream pane ;
-
-C: <pane-stream> pane-stream
-
-: smash-line ( current -- gadget )
- dup gadget-children {
- { [ dup empty? ] [ 2drop "" <label> ] }
- { [ dup length 1 = ] [ nip first ] }
- [ drop ]
- } cond ;
-
-: smash-pane ( pane -- gadget ) pane-output smash-line ;
-
-: pane-nl ( pane -- pane )
- dup pane-current dup unparent smash-line
- over pane-output add-incremental
- prepare-line ;
-
-: pane-write ( pane seq -- )
- [ pane-nl ]
- [ over pane-current stream-write ]
- interleave drop ;
-
-: pane-format ( style pane seq -- )
- [ pane-nl ]
- [ 2over pane-current stream-format ]
- interleave 2drop ;
-
-GENERIC: write-gadget ( gadget stream -- )
-
-M: pane-stream write-gadget ( gadget pane-stream -- )
- pane>> current>> swap add-gadget drop ;
-
-M: style-stream write-gadget
- stream>> write-gadget ;
-
-: print-gadget ( gadget stream -- )
- tuck write-gadget stream-nl ;
-
-: gadget. ( gadget -- )
- output-stream get print-gadget ;
-
-: ?nl ( stream -- )
- dup pane-stream-pane pane-current gadget-children empty?
- [ dup stream-nl ] unless drop ;
-
-: with-pane ( pane quot -- )
- over scroll>top
- over pane-clear >r <pane-stream> r>
- over >r with-output-stream* r> ?nl ; inline
-
-: make-pane ( quot -- gadget )
- <pane> [ swap with-pane ] keep smash-pane ; inline
-
-: <scrolling-pane> ( -- pane )
- <pane> t over set-pane-scrolls? ;
-
-TUPLE: pane-control < pane quot ;
-
-M: pane-control model-changed ( model pane-control -- )
- [ value>> ] [ dup quot>> ] bi* with-pane ;
-
-: <pane-control> ( model quot -- pane )
- pane-control new-pane
- swap >>quot
- swap >>model ;
-
-: do-pane-stream ( pane-stream quot -- )
- >r pane-stream-pane r> keep scroll-pane ; inline
-
-M: pane-stream stream-nl
- [ pane-nl drop ] do-pane-stream ;
-
-M: pane-stream stream-write1
- [ pane-current stream-write1 ] do-pane-stream ;
-
-M: pane-stream stream-write
- [ swap string-lines pane-write ] do-pane-stream ;
-
-M: pane-stream stream-format
- [ rot string-lines pane-format ] do-pane-stream ;
-
-M: pane-stream dispose drop ;
-
-M: pane-stream stream-flush drop ;
-
-M: pane-stream make-span-stream
- swap <style-stream> <ignore-close-stream> ;
-
-! Character styles
-
-: apply-style ( style gadget key quot -- style gadget )
- >r pick at r> when* ; inline
-
-: apply-foreground-style ( style gadget -- style gadget )
- foreground [ over set-label-color ] apply-style ;
-
-: apply-background-style ( style gadget -- style gadget )
- background [ solid-interior ] apply-style ;
-
-: specified-font ( style -- font )
- [ font swap at "monospace" or ] keep
- [ font-style swap at plain or ] keep
- font-size swap at 12 or 3array ;
-
-: apply-font-style ( style gadget -- style gadget )
- over specified-font over set-label-font ;
-
-: apply-presentation-style ( style gadget -- style gadget )
- presented [ <presentation> ] apply-style ;
-
-: style-label ( style gadget -- gadget )
- apply-foreground-style
- apply-background-style
- apply-font-style
- apply-presentation-style
- nip ; inline
-
-: <styled-label> ( style text -- gadget )
- <label> style-label ;
-
-! Paragraph styles
-
-: apply-wrap-style ( style pane -- style pane )
- wrap-margin [
- 2dup <paragraph> >>prototype drop
- <paragraph> >>current
- ] apply-style ;
-
-: apply-border-color-style ( style gadget -- style gadget )
- border-color [ solid-boundary ] apply-style ;
-
-: apply-page-color-style ( style gadget -- style gadget )
- page-color [ solid-interior ] apply-style ;
-
-: apply-path-style ( style gadget -- style gadget )
- presented-path [ <editable-slot> ] apply-style ;
-
-: apply-border-width-style ( style gadget -- style gadget )
- border-width [ <border> ] apply-style ;
-
-: apply-printer-style ( style gadget -- style gadget )
- presented-printer [ [ make-pane ] curry >>printer ] apply-style ;
-
-: style-pane ( style pane -- pane )
- apply-border-width-style
- apply-border-color-style
- apply-page-color-style
- apply-presentation-style
- apply-path-style
- apply-printer-style
- nip ;
-
-TUPLE: nested-pane-stream < pane-stream style parent ;
-
-: new-nested-pane-stream ( style parent class -- stream )
- new
- swap >>parent
- swap <pane> apply-wrap-style [ >>style ] [ >>pane ] bi* ;
- inline
-
-: unnest-pane-stream ( stream -- child parent )
- dup ?nl
- dup style>>
- over pane>> smash-pane style-pane
- swap parent>> ;
-
-TUPLE: pane-block-stream < nested-pane-stream ;
-
-M: pane-block-stream dispose
- unnest-pane-stream write-gadget ;
-
-M: pane-stream make-block-stream
- pane-block-stream new-nested-pane-stream ;
-
-! Tables
-: apply-table-gap-style ( style grid -- style grid )
- table-gap [ over set-grid-gap ] apply-style ;
-
-: apply-table-border-style ( style grid -- style grid )
- table-border [ <grid-lines> over set-gadget-boundary ]
- apply-style ;
-
-: styled-grid ( style grid -- grid )
- <grid>
- f over set-grid-fill?
- apply-table-gap-style
- apply-table-border-style
- nip ;
-
-TUPLE: pane-cell-stream < nested-pane-stream ;
-
-M: pane-cell-stream dispose ?nl ;
-
-M: pane-stream make-cell-stream
- pane-cell-stream new-nested-pane-stream ;
-
-M: pane-stream stream-write-table
- >r
- swap [ [ pane-stream-pane smash-pane ] map ] map
- styled-grid
- r> print-gadget ;
-
-! Stream utilities
-M: pack dispose drop ;
-
-M: paragraph dispose drop ;
-
-: gadget-write ( string gadget -- )
- over empty?
- [ 2drop ] [ >r <label> text-theme r> swap add-gadget drop ] if ;
-
-M: pack stream-write gadget-write ;
-
-: gadget-bl ( style stream -- )
- >r " " <word-break-gadget> style-label r> swap add-gadget drop ;
-
-M: paragraph stream-write
- swap " " split
- [ H{ } over gadget-bl ] [ over gadget-write ] interleave
- drop ;
-
-: gadget-write1 ( char gadget -- )
- >r 1string r> stream-write ;
-
-M: pack stream-write1 gadget-write1 ;
-
-M: paragraph stream-write1
- over CHAR: \s =
- [ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
-
-: gadget-format ( string style stream -- )
- pick empty?
- [ 3drop ] [ >r swap <styled-label> r> swap add-gadget drop ] if ;
-
-M: pack stream-format
- gadget-format ;
-
-M: paragraph stream-format
- presented pick at [
- gadget-format
- ] [
- rot " " split
- [ 2dup gadget-bl ]
- [ 2over gadget-format ] interleave
- 2drop
- ] if ;
-
-: caret>mark ( pane -- pane )
- dup caret>> >>mark
- dup relayout-1 ;
-
-GENERIC: sloppy-pick-up* ( loc gadget -- n )
-
-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 ;
-
-M: f sloppy-pick-up*
- 2drop f ;
-
-: wet-and-sloppy ( loc gadget n -- newloc newgadget )
- swap nth-gadget [ rect-loc v- ] keep ;
-
-: sloppy-pick-up ( loc gadget -- path )
- 2dup sloppy-pick-up* dup
- [ [ wet-and-sloppy sloppy-pick-up ] keep prefix ]
- [ 3drop { } ]
- if ;
-
-: move-caret ( pane -- pane )
- dup hand-rel
- over sloppy-pick-up
- over set-pane-caret
- dup relayout-1 ;
-
-: begin-selection ( pane -- )
- move-caret f swap set-pane-mark ;
-
-: extend-selection ( pane -- )
- hand-moved? [
- dup selecting?>> [
- move-caret
- ] [
- dup hand-clicked get child? [
- t >>selecting?
- dup hand-clicked set-global
- move-caret
- caret>mark
- ] when
- ] if
- dup dup pane-caret gadget-at-path scroll>gadget
- ] when drop ;
-
-: end-selection ( pane -- )
- f >>selecting?
- hand-moved? [
- [ com-copy-selection ] [ request-focus ] bi
- ] [
- relayout-1
- ] if ;
-
-: select-to-caret ( pane -- )
- dup pane-mark [ caret>mark ] unless
- move-caret
- dup request-focus
- com-copy-selection ;
-
-pane H{
- { T{ button-down } [ begin-selection ] }
- { T{ button-down f { S+ } 1 } [ select-to-caret ] }
- { T{ button-up f { S+ } 1 } [ drop ] }
- { T{ button-up } [ end-selection ] }
- { T{ drag } [ extend-selection ] }
- { T{ copy-action } [ com-copy ] }
-} set-gestures
+++ /dev/null
-Pane gadgets display formatted stream output
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2005, 2007 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ui.gadgets ui.gadgets.labels ui.render kernel math
-namespaces sequences math.order math.geometry.rect ;
-IN: ui.gadgets.paragraphs
-
-! A word break gadget
-TUPLE: word-break-gadget < label ;
-
-: <word-break-gadget> ( text -- gadget )
- word-break-gadget new-label ;
-
-M: word-break-gadget draw-gadget* drop ;
-
-! A gadget that arranges its children in a word-wrap style.
-TUPLE: paragraph < gadget margin ;
-
-: <paragraph> ( margin -- gadget )
- paragraph new-gadget
- { 1 0 } over set-gadget-orientation
- [ set-paragraph-margin ] keep ;
-
-SYMBOL: x SYMBOL: max-x
-
-SYMBOL: y SYMBOL: max-y
-
-SYMBOL: line-height
-
-SYMBOL: margin
-
-: overrun? ( width -- ? ) x get + margin get > ;
-
-: zero-vars ( seq -- ) [ 0 swap set ] each ;
-
-: wrap-line ( -- )
- line-height get y +@
- { x line-height } zero-vars ;
-
-: wrap-pos ( -- pos ) x get y get 2array ; inline
-
-: advance-x ( x -- )
- x +@
- x get max-x [ max ] change ;
-
-: advance-y ( y -- )
- dup line-height [ max ] change
- y get + max-y [ max ] change ;
-
-: wrap-step ( quot child -- )
- dup pref-dim [
- over word-break-gadget? [
- dup first overrun? [ wrap-line ] when
- ] unless drop wrap-pos rot call
- ] keep first2 advance-y advance-x ; inline
-
-: wrap-dim ( -- dim ) max-x get max-y get 2array ;
-
-: init-wrap ( paragraph -- )
- paragraph-margin margin set
- { x max-x y max-y line-height } zero-vars ;
-
-: do-wrap ( paragraph quot -- dim )
- [
- swap dup init-wrap
- [ wrap-step ] with each-child wrap-dim
- ] with-scope ; inline
-
-M: paragraph pref-dim*
- [ 2drop ] do-wrap ;
-
-M: paragraph layout*
- [ swap dup prefer set-rect-loc ] do-wrap drop ;
+++ /dev/null
-Paragraph gadgets lay out their children from left to right, wrapping at a fixed margin
+++ /dev/null
-
-USING: kernel quotations arrays sequences math math.ranges fry
- opengl opengl.gl ui.render ui.gadgets.cartesian processing.shapes
- accessors ;
-
-IN: ui.gadgets.plot
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: plot < cartesian functions points ;
-
-: init-plot ( plot -- plot )
- init-cartesian
- { } >>functions
- 100 >>points ;
-
-: <plot> ( -- plot ) plot new init-plot ;
-
-: step-size ( plot -- step-size )
- [ [ x-max>> ] [ x-min>> ] bi - ] [ points>> ] bi / ;
-
-: plot-range ( plot -- range )
- [ x-min>> ] [ x-max>> ] [ step-size ] tri <range> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: function function color ;
-
-GENERIC: plot-function ( plot object -- plot )
-
-M: quotation plot-function ( plot quotation -- plot )
- >r dup plot-range r> '[ dup @ 2array ] map line-strip ;
-
-M: function plot-function ( plot function -- plot )
- dup color>> dup [ >stroke-color ] [ drop ] if
- >r dup plot-range r> function>> '[ dup @ 2array ] map line-strip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: plot-functions ( plot -- plot ) dup functions>> [ plot-function ] each ;
-
-: draw-axis ( plot -- plot )
- dup
- [ [ x-min>> ] [ drop 0 ] bi 2array ]
- [ [ x-max>> ] [ drop 0 ] bi 2array ] bi line*
- dup
- [ [ drop 0 ] [ y-min>> ] bi 2array ]
- [ [ drop 0 ] [ y-max>> ] bi 2array ] bi line* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: ui.gadgets.slate ;
-
-M: plot draw-slate ( plot -- plot )
- 2 glLineWidth
- draw-axis
- plot-functions
- fill-mode
- 1 glLineWidth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: add-function ( plot function -- plot )
- over functions>> swap suffix >>functions ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: x-span ( plot -- span ) [ x-max>> ] [ x-min>> ] bi - ;
-: y-span ( plot -- span ) [ y-max>> ] [ y-min>> ] bi - ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: ui.gestures ui.gadgets ;
-
-: left ( plot -- plot )
- dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min
- dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max
- dup relayout-1 ;
-
-: right ( plot -- plot )
- dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min
- dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max
- dup relayout-1 ;
-
-: down ( plot -- plot )
- dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min
- dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max
- dup relayout-1 ;
-
-: up ( plot -- plot )
- dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min
- dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max
- dup relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: zoom-in-horizontal ( plot -- plot )
- dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min
- dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max ;
-
-: zoom-in-vertical ( plot -- plot )
- dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min
- dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max ;
-
-: zoom-in ( plot -- plot )
- zoom-in-horizontal
- zoom-in-vertical
- dup relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: zoom-out-horizontal ( plot -- plot )
- dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min
- dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max ;
-
-: zoom-out-vertical ( plot -- plot )
- dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min
- dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max ;
-
-: zoom-out ( plot -- plot )
- zoom-out-horizontal
- zoom-out-vertical
- dup relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-plot
- H{
- { T{ mouse-enter } [ request-focus ] }
- { T{ key-down f f "LEFT" } [ left drop ] }
- { T{ key-down f f "RIGHT" } [ right drop ] }
- { T{ key-down f f "DOWN" } [ down drop ] }
- { T{ key-down f f "UP" } [ up drop ] }
- { T{ key-down f f "a" } [ zoom-in drop ] }
- { T{ key-down f f "z" } [ zoom-out drop ] }
- }
-set-gestures
\ No newline at end of file
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax ui.gadgets.buttons
-ui.gadgets.menus models ui.operations summary kernel
-ui.gadgets.worlds ui.gadgets ui.gadgets.status-bar ;
-IN: ui.gadgets.presentations
-
-HELP: presentation
-{ $class-description "A presentation is a " { $link button } " which represents an object. Left-clicking a presentation invokes the default " { $link operation } ", and right-clicking displays a menu of possible operations output by " { $link object-operations } "."
-$nl
-"Presentations are created by calling " { $link <presentation> } "."
-$nl
-"Presentations have two slots:"
-{ $list
- { { $link presentation-object } " - the object being presented." }
- { { $link presentation-hook } " - a quotation with stack effect " { $snippet "( presentation -- )" } ". The default value is " { $snippet "[ drop ]" } "." }
-} } ;
-
-HELP: invoke-presentation
-{ $values { "presentation" presentation } { "command" "a command" } }
-{ $description "Calls the " { $link presentation-hook } " and then invokes the command on the " { $link presentation-object } "." } ;
-
-{ invoke-presentation invoke-primary invoke-secondary } related-words
-
-HELP: invoke-primary
-{ $values { "presentation" presentation } }
-{ $description "Invokes the " { $link primary-operation } " associated to the " { $link presentation-object } ". This word is executed when the presentation is clicked with the left mouse button." } ;
-
-HELP: invoke-secondary
-{ $values { "presentation" presentation } }
-{ $description "Invokes the " { $link secondary-operation } " associated to the " { $link presentation-object } ". This word is executed when a list receives a " { $snippet "RET" } " key press." } ;
-
-HELP: <presentation>
-{ $values { "label" "a label" } { "object" object } { "button" "a new " { $link button } } }
-{ $description "Creates a new " { $link presentation } " derived from " { $link <roll-button> } "." }
-{ $see-also "presentations" } ;
-
-{ <button> <bevel-button> <command-button> <roll-button> <presentation> } related-words
-
-{ <commands-menu> <toolbar> operations-menu show-menu } related-words
-
-{ <status-bar> show-mouse-help show-status show-summary hide-status } related-words
-
-HELP: show-mouse-help
-{ $values { "presentation" presentation } }
-{ $description "Displays a " { $link summary } " of the " { $link presentation-object } "in the status bar of the " { $link world } " containing this presentation. This word is executed when the mouse enters the presentation." } ;
-
-ARTICLE: "ui.gadgets.presentations" "Presentation gadgets"
-"Outliner gadgets are usually not constructed directly, and instead are written to " { $link "ui.gadgets.panes" } " with formatted stream output words (" { $link "presentations" } ")."
-{ $subsection presentation }
-{ $subsection <presentation> }
-"Presentations remember the object they are presenting; operations can be performed on the presented object. See " { $link "ui-operations" } "." ;
-
-ABOUT: "ui.gadgets.presentations"
+++ /dev/null
-IN: ui.gadgets.presentations.tests
-USING: math ui.gadgets.presentations ui.gadgets tools.test
-prettyprint ui.gadgets.buttons io io.streams.string kernel
-classes.tuple ;
-
-[ t ] [
- "Hi" \ + <presentation> [ gadget? ] is?
-] unit-test
-
-[ "+" ] [
- [
- \ + f \ pprint <command-button> dup button-quot call
- ] with-string-writer
-] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays accessors definitions hashtables io kernel
-prettyprint sequences strings io.styles words help math models
-namespaces quotations
-ui.gadgets ui.gadgets.borders ui.gadgets.buttons
-ui.gadgets.labels ui.gadgets.menus ui.gadgets.worlds
-ui.gadgets.status-bar ui.commands ui.operations ui.gestures ;
-IN: ui.gadgets.presentations
-
-TUPLE: presentation < button object hook ;
-
-: invoke-presentation ( presentation command -- )
- over dup presentation-hook call
- >r presentation-object r> invoke-command ;
-
-: invoke-primary ( presentation -- )
- dup presentation-object primary-operation
- invoke-presentation ;
-
-: invoke-secondary ( presentation -- )
- dup presentation-object secondary-operation
- invoke-presentation ;
-
-: show-mouse-help ( presentation -- )
- dup presentation-object over show-summary button-update ;
-
-: <presentation> ( label object -- button )
- swap [ invoke-primary ] presentation new-button
- swap >>object
- [ drop ] >>hook
- roll-button-theme ;
-
-M: presentation ungraft*
- dup hand-gadget get-global child? [ dup hide-status ] when
- call-next-method ;
-
-: <operations-menu> ( presentation -- menu )
- dup dup presentation-hook curry
- swap presentation-object
- dup object-operations <commands-menu> ;
-
-: operations-menu ( presentation -- )
- dup <operations-menu> swap show-menu ;
-
-presentation H{
- { T{ button-down f f 3 } [ operations-menu ] }
- { T{ mouse-leave } [ dup hide-status button-update ] }
- { T{ mouse-enter } [ show-mouse-help ] }
- ! Responding to motion too allows nested presentations to
- ! display status help properly, when the mouse leaves a
- ! nested presentation and is still inside the parent, the
- ! parent doesn't receive a mouse-enter
- { T{ motion } [ show-mouse-help ] }
-} set-gestures
+++ /dev/null
-Presentations display an interactive view of an object
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets help.markup help.syntax ui.gadgets.viewports
-ui.gadgets.sliders math.geometry.rect ;
-IN: ui.gadgets.scrollers
-
-HELP: scroller
-{ $class-description "A scroller consists of a " { $link viewport } " containing a child, together with horizontal and vertical " { $link slider } " gadgets which scroll the viewport's child. Scroller gadgets also support using a mouse scroll wheel."
-$nl
-"Scroller gadgets are created by calling " { $link <scroller> } "." } ;
-
-HELP: find-scroller
-{ $values { "gadget" gadget } { "scroller/f" "a " { $link scroller } " or " { $link f } } }
-{ $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link scroller } ". Outputs " { $link f } " if the gadget is not contained in a " { $link scroller } "." } ;
-
-HELP: scroller-value
-{ $values { "scroller" scroller } { "loc" "a pair of integers" } }
-{ $description "Outputs the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ;
-
-{ scroller-value scroll scroll>bottom scroll>top scroll>rect } related-words
-
-HELP: <scroller>
-{ $values { "gadget" gadget } { "scroller" "a new " { $link scroller } } }
-{ $description "Creates a new " { $link scroller } " for scrolling around " { $snippet "gadget" } "." } ;
-
-{ <viewport> <scroller> } related-words
-
-HELP: scroll
-{ $values { "scroller" scroller } { "value" "a pair of integers" } }
-{ $description "Sets the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ;
-
-HELP: relative-scroll-rect
-{ $values { "rect" rect } { "gadget" gadget } { "scroller" scroller } { "newrect" "a new " { $link rect } } }
-{ $description "Adjusts " { $snippet "rect" } " for the case where the gadget is not the immediate child of the scroller's viewport." } ;
-
-HELP: scroll>rect
-{ $values { "rect" rect } { "gadget" gadget } }
-{ $description "Ensures that a rectangular region relative to the top-left corner of " { $snippet "gadget" } " becomes visible in a " { $link scroller } " containing " { $snippet "gadget" } ". Does nothing if no parent of " { $snippet "gadget" } " is a " { $link scroller } "." } ;
-
-HELP: scroll>bottom
-{ $values { "gadget" gadget } }
-{ $description "Ensures that any " { $link scroller } " containing " { $snippet "gadget" } " is scrolled all the way down. Does nothing if no parent of " { $snippet "gadget" } " is a " { $link scroller } "." } ;
-
-HELP: scroll>top
-{ $values { "gadget" gadget } }
-{ $description "Ensures that any scroller containing " { $snippet "gadget" } " is scrolled all the way up. If no parent of " { $snippet "scroller" } " is a gadget, does nothing." } ;
-
-ARTICLE: "ui.gadgets.scrollers" "Scroller gadgets"
-"A scroller displays a gadget which is larger than the visible area."
-{ $subsection scroller }
-{ $subsection <scroller> }
-"Getting and setting the scroll position:"
-{ $subsection scroller-value }
-{ $subsection scroll }
-"Writing scrolling-aware gadgets:"
-{ $subsection scroll>bottom }
-{ $subsection scroll>top }
-{ $subsection scroll>rect }
-{ $subsection find-scroller } ;
-
-ABOUT: "ui.gadgets.scrollers"
+++ /dev/null
-IN: ui.gadgets.scrollers.tests
-USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test
-kernel models models.compose models.range ui.gadgets.viewports
-ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
-ui.gadgets.sliders math math.vectors arrays sequences
-tools.test.ui math.geometry.rect ;
-
-[ ] [
- <gadget> "g" set
- "g" get <scroller> "s" set
-] unit-test
-
-[ { 100 200 } ] [
- { 100 200 } "g" get scroll>rect
- "s" get scroller-follows rect-loc
-] unit-test
-
-[ ] [ "s" get scroll>bottom ] unit-test
-[ t ] [ "s" get scroller-follows ] unit-test
-
-[ ] [
- <gadget> dup "g" set
- 10 1 0 100 <range> 20 1 0 100 <range> 2array <compose>
- <viewport> "v" set
-] unit-test
-
-"v" get [
- [ { 10 20 } ] [ "v" get gadget-model range-value ] unit-test
-
- [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
-] with-grafted-gadget
-
-[ ] [
- <gadget> { 100 100 } over set-rect-dim
- dup "g" set <scroller> "s" set
-] unit-test
-
-[ ] [ { 50 50 } "s" get set-rect-dim ] unit-test
-
-[ ] [ "s" get layout ] unit-test
-
-"s" get [
- [ { 34 34 } ] [ "s" get scroller-viewport rect-dim ] unit-test
-
- [ { 106 106 } ] [ "s" get scroller-viewport viewport-dim ] unit-test
-
- [ ] [ { 0 0 } "s" get scroll ] unit-test
-
- [ { 0 0 } ] [ "s" get gadget-model range-min-value ] unit-test
-
- [ { 106 106 } ] [ "s" get gadget-model range-max-value ] unit-test
-
- [ ] [ { 10 20 } "s" get scroll ] unit-test
-
- [ { 10 20 } ] [ "s" get gadget-model range-value ] unit-test
-
- [ { 10 20 } ] [ "s" get scroller-viewport gadget-model range-value ] unit-test
-
- [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
-] with-grafted-gadget
-
-<gadget> { 600 400 } over set-rect-dim "g1" set
-<gadget> { 600 10 } over set-rect-dim "g2" set
-"g2" get "g1" get swap add-gadget drop
-
-"g1" get <scroller>
-{ 300 300 } over set-rect-dim
-dup layout
-"s" set
-
-[ t ] [
- 10 [
- drop
- "g2" get scroll>gadget
- "s" get layout
- "s" get scroller-value
- ] map [ { 3 0 } = ] all?
-] unit-test
-
-[ ] [ "Hi" <label> dup "l" set <scroller> "s" set ] unit-test
-
-[ t ] [ "l" get find-scroller "s" get eq? ] unit-test
-[ t ] [ "l" get dup find-scroller scroller-viewport swap child? ] unit-test
-[ t ] [ "l" get find-scroller* "s" get eq? ] unit-test
-[ f ] [ "s" get scroller-viewport find-scroller* ] unit-test
-[ t ] [ "s" get @right grid-child slider? ] unit-test
-[ f ] [ "s" get @right grid-child find-scroller* ] unit-test
-
-\ <scroller> must-infer
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays ui.gadgets ui.gadgets.viewports
-ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
-ui.gadgets.sliders ui.gestures kernel math namespaces sequences
-models models.range models.compose
-combinators math.vectors classes.tuple math.geometry.rect ;
-IN: ui.gadgets.scrollers
-
-TUPLE: scroller < frame viewport x y follows ;
-
-: find-scroller ( gadget -- scroller/f )
- [ [ scroller? ] is? ] find-parent ;
-
-: scroll-up-page ( scroller -- ) y>> -1 swap slide-by-page ;
-
-: scroll-down-page ( scroller -- ) y>> 1 swap slide-by-page ;
-
-: scroll-up-line ( scroller -- ) y>> -1 swap slide-by-line ;
-
-: scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
-
-: do-mouse-scroll ( scroller -- )
- scroll-direction get-global first2
- pick scroller-y slide-by-line
- swap scroller-x slide-by-line ;
-
-scroller H{
- { T{ mouse-scroll } [ do-mouse-scroll ] }
-} set-gestures
-
-: <scroller-model> ( -- model )
- 0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
-
-: new-scroller ( gadget class -- scroller )
- new-frame
- t >>root?
- <scroller-model> >>model
- faint-boundary
-
- dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add
- dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
-
- swap over model>> <viewport> >>viewport
- dup viewport>> @center grid-add ;
-
-: <scroller> ( gadget -- scroller ) scroller new-scroller ;
-
-: scroll ( value scroller -- )
- [
- dup scroller-viewport rect-dim { 0 0 }
- rot scroller-viewport viewport-dim 4array flip
- ] keep
- 2dup control-value = [ 2drop ] [ set-control-value ] if ;
-
-: rect-min ( rect1 rect2 -- rect )
- >r [ rect-loc ] keep r> [ rect-dim ] bi@ vmin <rect> ;
-
-: (scroll>rect) ( rect scroller -- )
- [
- scroller-value vneg offset-rect
- viewport-gap offset-rect
- ] keep
- [ scroller-viewport rect-min ] keep
- [
- scroller-viewport 2rect-extent
- >r >r v- { 0 0 } vmin r> r> v- { 0 0 } vmax v+
- ] keep dup scroller-value rot v+ swap scroll ;
-
-: relative-scroll-rect ( rect gadget scroller -- newrect )
- viewport>> gadget-child relative-loc offset-rect ;
-
-: find-scroller* ( gadget -- scroller )
- dup find-scroller dup [
- 2dup scroller-viewport gadget-child
- swap child? [ nip ] [ 2drop f ] if
- ] [
- 2drop f
- ] if ;
-
-: scroll>rect ( rect gadget -- )
- dup find-scroller* dup [
- [ relative-scroll-rect ] keep
- [ set-scroller-follows ] keep
- relayout
- ] [
- 3drop
- ] if ;
-
-: (scroll>gadget) ( gadget scroller -- )
- >r { 0 0 } over pref-dim <rect> swap r>
- [ relative-scroll-rect ] keep
- (scroll>rect) ;
-
-: scroll>gadget ( gadget -- )
- dup find-scroller* dup [
- [ set-scroller-follows ] keep
- relayout
- ] [
- 2drop
- ] if ;
-
-: (scroll>bottom) ( scroller -- )
- dup scroller-viewport viewport-dim { 0 1 } v* swap scroll ;
-
-: scroll>bottom ( gadget -- )
- find-scroller [
- t over set-scroller-follows relayout-1
- ] when* ;
-
-: scroll>top ( gadget -- )
- <zero-rect> swap scroll>rect ;
-
-GENERIC: update-scroller ( scroller follows -- )
-
-M: t update-scroller drop (scroll>bottom) ;
-
-M: gadget update-scroller swap (scroll>gadget) ;
-
-M: rect update-scroller swap (scroll>rect) ;
-
-M: f update-scroller drop dup scroller-value swap scroll ;
-
-M: scroller layout*
- dup call-next-method
- dup scroller-follows
- [ update-scroller ] 2keep
- swap set-scroller-follows ;
-
-M: scroller focusable-child*
- scroller-viewport ;
-
-M: scroller model-changed
- nip f swap set-scroller-follows ;
-
-TUPLE: limited-scroller < scroller fixed-dim ;
-
-: <limited-scroller> ( gadget dim -- scroller )
- >r limited-scroller new-scroller r> >>fixed-dim ;
-
-M: limited-scroller pref-dim*
- fixed-dim>> ;
+++ /dev/null
-Scrollers display a user-chosen portion of a child which may have arbitrary dimensions
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces opengl ui.render ui.gadgets accessors ;
-
-IN: ui.gadgets.slate
-
-TUPLE: slate < gadget action pdim graft ungraft ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-slate ( slate -- slate )
- init-gadget
- [ ] >>action
- { 200 200 } >>pdim
- [ ] >>graft
- [ ] >>ungraft ;
-
-: <slate> ( action -- slate )
- slate new
- init-slate
- swap >>action ;
-
-M: slate pref-dim* ( slate -- dim ) pdim>> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: combinators arrays sequences math math.geometry
- opengl.gl ui.gadgets.worlds ;
-
-: screen-y* ( gadget -- loc )
- {
- [ find-world height ]
- [ screen-loc second ]
- [ height ]
- }
- cleave
- + - ;
-
-: screen-loc* ( gadget -- loc )
- {
- [ screen-loc first ]
- [ screen-y* ]
- }
- cleave
- 2array ;
-
-: setup-viewport ( gadget -- gadget )
- dup
- {
- [ screen-loc* ]
- [ dim>> ]
- }
- cleave
- gl-viewport ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: default-coordinate-system ( gadget -- gadget )
- dup
- {
- [ drop 0 ]
- [ width 1 - ]
- [ height 1 - ]
- [ drop 0 ]
- }
- cleave
- -1 1
- glOrtho ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate graft* ( slate -- ) graft>> call ;
-M: slate ungraft* ( slate -- ) ungraft>> call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: establish-coordinate-system ( gadget -- gadget )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate establish-coordinate-system ( slate -- slate )
- default-coordinate-system ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: draw-slate ( slate -- slate )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate draw-slate ( slate -- slate ) dup action>> call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate draw-gadget* ( slate -- )
-
- GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity
-
- establish-coordinate-system
-
- GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity
-
- setup-viewport
-
- draw-slate
-
- GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity
- GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity
-
- dup
- find-world
- ! The world coordinate system is a little wacky:
- dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho
- setup-viewport
- drop
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax ui.gadgets models models.range ;
-IN: ui.gadgets.sliders
-
-HELP: elevator
-{ $class-description "An elevator is the part of a " { $link slider } " between the up/down arrow buttons, where a " { $link thumb } " may be moved up and down." } ;
-
-HELP: find-elevator
-{ $values { "gadget" gadget } { "elevator/f" "an " { $link elevator } " or " { $link f } } }
-{ $description "Finds the first parent of " { $snippet "gadget" } " which is an " { $link elevator } ". Outputs " { $link f } " if the gadget is not contained in an " { $link elevator } "." } ;
-
-HELP: slider
-{ $class-description "A slider is a control for graphically manipulating a " { $link "models-range" } "."
-$nl
-"Sliders are created by calling " { $link <x-slider> } " or " { $link <y-slider> } "." } ;
-
-HELP: find-slider
-{ $values { "gadget" gadget } { "slider/f" "a " { $link slider } " or " { $link f } } }
-{ $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link slider } ". Outputs " { $link f } " if the gadget is not contained in a " { $link slider } "." } ;
-
-HELP: thumb
-{ $class-description "A thumb is the gadget contained in a " { $link slider } "'s " { $link elevator } " which indicates the current scroll position and can be dragged up and down with the mouse." } ;
-
-HELP: slide-by
-{ $values { "amount" "an integer" } { "slider" slider } }
-{ $description "Adds the amount (which may be positive or negative) to the slider's current position." } ;
-
-HELP: slide-by-page
-{ $values { "amount" "an integer" } { "slider" slider } }
-{ $description "Adds the amount multiplied by " { $link slider-page } " to the slider's current position." } ;
-
-HELP: slide-by-line
-{ $values { "amount" "an integer" } { "slider" slider } }
-{ $description "Adds the amount multiplied by " { $link slider-line } " to the slider's current position." } ;
-
-HELP: <slider>
-{ $values { "range" range } { "orientation" "an orientation specifier" } { "slider" "a new " { $link slider } } }
-{ $description "Internal word for constructing sliders." }
-{ $notes "This does not build a complete slider, and user code should call " { $link <x-slider> } " or " { $link <y-slider> } " instead." } ;
-
-HELP: <x-slider>
-{ $values { "range" range } { "slider" slider } }
-{ $description "Creates a new horizontal " { $link slider } "." } ;
-
-HELP: <y-slider>
-{ $values { "range" range } { "slider" slider } }
-{ $description "Creates a new vertical " { $link slider } "." } ;
-
-{ <x-slider> <y-slider> } related-words
-
-ARTICLE: "ui.gadgets.sliders" "Slider gadgets"
-"A slider allows the user to graphically manipulate a value by moving a thumb back and forth."
-{ $subsection slider }
-{ $subsection <x-slider> }
-{ $subsection <y-slider> }
-"Changing slider values:"
-{ $subsection slide-by }
-{ $subsection slide-by-line }
-{ $subsection slide-by-page }
-"Since sliders are controls the value can be get and set by calling " { $link gadget-model } "." ;
-
-ABOUT: "ui.gadgets.sliders"
+++ /dev/null
-! Copyright (C) 2005, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
-ui.gadgets.frames ui.gadgets.grids math.order
-ui.gadgets.theme ui.render kernel math namespaces sequences
-vectors models models.range math.vectors math.functions
-quotations colors math.geometry.rect ;
-IN: ui.gadgets.sliders
-
-TUPLE: elevator < gadget direction ;
-
-: find-elevator ( gadget -- elevator/f ) [ elevator? ] find-parent ;
-
-TUPLE: slider < frame elevator thumb saved line ;
-
-: find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
-
-: elevator-length ( slider -- n )
- [ elevator>> dim>> ] [ orientation>> ] bi v. ;
-
-: min-thumb-dim 15 ;
-
-: slider-value ( gadget -- n ) gadget-model range-value >fixnum ;
-: slider-page ( gadget -- n ) gadget-model range-page-value ;
-: slider-max ( gadget -- n ) gadget-model range-max-value ;
-: slider-max* ( gadget -- n ) gadget-model range-max-value* ;
-
-: thumb-dim ( slider -- h )
- dup slider-page over slider-max 1 max / 1 min
- over elevator-length * min-thumb-dim max
- over slider-elevator rect-dim
- rot gadget-orientation v. min ;
-
-: slider-scale ( slider -- n )
- #! A scaling factor such that if x is a slider co-ordinate,
- #! x*n is the screen position of the thumb, and conversely
- #! for x/n. The '1 max' calls avoid division by zero.
- dup elevator-length over thumb-dim - 1 max
- swap slider-max* 1 max / ;
-
-: slider>screen ( m scale -- n ) slider-scale * ;
-: screen>slider ( m scale -- n ) slider-scale / ;
-
-M: slider model-changed nip slider-elevator relayout-1 ;
-
-TUPLE: thumb < gadget ;
-
-: begin-drag ( thumb -- )
- find-slider dup slider-value swap set-slider-saved ;
-
-: do-drag ( thumb -- )
- find-slider drag-loc over gadget-orientation v.
- over screen>slider swap [ slider-saved + ] keep
- gadget-model set-range-value ;
-
-thumb H{
- { T{ button-down } [ begin-drag ] }
- { T{ button-up } [ drop ] }
- { T{ drag } [ do-drag ] }
-} set-gestures
-
-: thumb-theme ( thumb -- thumb )
- plain-gradient >>interior
- faint-boundary ; inline
-
-: <thumb> ( vector -- thumb )
- thumb new-gadget
- swap >>orientation
- t >>root?
- thumb-theme ;
-
-: slide-by ( amount slider -- ) gadget-model move-by ;
-
-: slide-by-page ( amount slider -- ) gadget-model move-by-page ;
-
-: compute-direction ( elevator -- -1/1 )
- dup find-slider swap hand-click-rel
- over gadget-orientation v.
- over screen>slider
- swap slider-value - sgn ;
-
-: elevator-hold ( elevator -- )
- dup elevator-direction swap find-slider slide-by-page ;
-
-: elevator-click ( elevator -- )
- dup compute-direction over set-elevator-direction
- elevator-hold ;
-
-elevator H{
- { T{ drag } [ elevator-hold ] }
- { T{ button-down } [ elevator-click ] }
-} set-gestures
-
-: <elevator> ( vector -- elevator )
- elevator new-gadget
- swap >>orientation
- lowered-gradient >>interior ;
-
-: (layout-thumb) ( slider n -- n thumb )
- over gadget-orientation n*v swap slider-thumb ;
-
-: thumb-loc ( slider -- loc )
- dup slider-value swap slider>screen ;
-
-: layout-thumb-loc ( slider -- )
- dup thumb-loc (layout-thumb)
- >r [ floor ] map r> set-rect-loc ;
-
-: layout-thumb-dim ( slider -- )
- dup dup thumb-dim (layout-thumb) >r
- >r dup rect-dim r>
- rot gadget-orientation set-axis [ ceiling ] map
- r> (>>dim) ;
-
-: layout-thumb ( slider -- )
- dup layout-thumb-loc layout-thumb-dim ;
-
-M: elevator layout*
- find-slider layout-thumb ;
-
-: slide-by-line ( amount slider -- )
- [ slider-line * ] keep slide-by ;
-
-: <slide-button> ( vector polygon amount -- button )
- >r gray swap <polygon-gadget> r>
- [ swap find-slider slide-by-line ] curry <repeat-button>
- [ set-gadget-orientation ] keep ;
-
-: elevator, ( gadget orientation -- gadget )
- tuck <elevator> >>elevator
- swap <thumb> >>thumb
- dup elevator>> over thumb>> add-gadget
- @center grid-add ;
-
-: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
-: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
-: <up-button> ( -- button ) { 1 0 } arrow-up -1 <slide-button> ;
-: <down-button> ( -- button ) { 1 0 } arrow-down 1 <slide-button> ;
-
-: <slider> ( range orientation -- slider )
- slider new-frame
- swap >>orientation
- swap >>model
- 32 >>line ;
-
-: <x-slider> ( range -- slider )
- { 1 0 } <slider>
- <left-button> @left grid-add
- { 0 1 } elevator,
- <right-button> @right grid-add ;
-
-: <y-slider> ( range -- slider )
- { 0 1 } <slider>
- <up-button> @top grid-add
- { 1 0 } elevator,
- <down-button> @bottom grid-add ;
-
-M: slider pref-dim*
- dup call-next-method
- swap gadget-orientation [ 40 v*n ] keep
- set-axis ;
+++ /dev/null
-Slider gadgets provide a graphical view of an integer-valued model
+++ /dev/null
-Slava Pestov
+++ /dev/null
-IN: ui.gadgets.slots.tests
-USING: assocs ui.gadgets.slots tools.test refs ;
-
-\ <editable-slot> must-infer
-
-[ t ] [ { 1 2 3 } 2 <value-ref> <slot-editor> slot-editor? ] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel parser prettyprint
-sequences arrays io math definitions math.vectors assocs refs
-ui.gadgets ui.gestures ui.commands ui.gadgets.scrollers
-ui.gadgets.buttons ui.gadgets.borders ui.gadgets.tracks
-ui.gadgets.editors eval ;
-IN: ui.gadgets.slots
-
-TUPLE: update-object ;
-
-TUPLE: update-slot ;
-
-TUPLE: edit-slot ;
-
-TUPLE: slot-editor < track ref text ;
-
-: revert ( slot-editor -- )
- dup slot-editor-ref get-ref unparse-use
- swap slot-editor-text set-editor-string ;
-
-\ revert H{
- { +description+ "Revert any uncomitted changes." }
-} define-command
-
-GENERIC: finish-editing ( slot-editor ref -- )
-
-M: key-ref finish-editing
- drop T{ update-object } swap send-gesture drop ;
-
-M: value-ref finish-editing
- drop T{ update-slot } swap send-gesture drop ;
-
-: slot-editor-value ( slot-editor -- object )
- slot-editor-text control-value parse-fresh ;
-
-: commit ( slot-editor -- )
- dup slot-editor-text control-value parse-fresh first
- over slot-editor-ref set-ref
- dup slot-editor-ref finish-editing ;
-
-\ commit H{
- { +description+ "Parse the object being edited, and store the result back into the edited slot." }
-} define-command
-
-: com-eval ( slot-editor -- )
- [ slot-editor-text editor-string eval ] keep
- [ slot-editor-ref set-ref ] keep
- dup slot-editor-ref finish-editing ;
-
-\ com-eval H{
- { +listener+ t }
- { +description+ "Parse code which evaluates to an object, and store the result back into the edited slot." }
-} define-command
-
-: delete ( slot-editor -- )
- dup slot-editor-ref delete-ref
- T{ update-object } swap send-gesture drop ;
-
-\ delete H{
- { +description+ "Delete the slot and close the slot editor." }
-} define-command
-
-: close ( slot-editor -- )
- T{ update-slot } swap send-gesture drop ;
-
-\ close H{
- { +description+ "Close the slot editor without saving changes." }
-} define-command
-
-: <slot-editor> ( ref -- gadget )
- { 0 1 } slot-editor new-track
- swap >>ref
- dup <toolbar> f track-add
- <source-editor> >>text
- dup text>> <scroller> 1 track-add
- dup revert ;
-
-M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
-
-M: slot-editor focusable-child* text>> ;
-
-slot-editor "toolbar" f {
- { T{ key-down f { C+ } "RET" } commit }
- { T{ key-down f { S+ C+ } "RET" } com-eval }
- { f revert }
- { f delete }
- { T{ key-down f f "ESC" } close }
-} define-command-map
-
-TUPLE: editable-slot < track printer ref ;
-
-: <edit-button> ( -- gadget )
- "..."
- [ T{ edit-slot } swap send-gesture drop ]
- <roll-button> ;
-
-: display-slot ( gadget editable-slot -- )
- dup clear-track
- swap 1 track-add
- <edit-button> f track-add
- drop ;
-
-: update-slot ( editable-slot -- )
- [ [ ref>> get-ref ] [ printer>> ] bi call ] keep
- display-slot ;
-
-: edit-slot ( editable-slot -- )
- [ clear-track ]
- [
- dup ref>> <slot-editor>
- [ 1 track-add drop ]
- [ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
- ] bi ;
-
-\ editable-slot H{
- { T{ update-slot } [ update-slot ] }
- { T{ edit-slot } [ edit-slot ] }
-} set-gestures
-
-: <editable-slot> ( gadget ref -- editable-slot )
- { 1 0 } editable-slot new-track
- swap >>ref
- [ drop <gadget> ] >>printer
- [ display-slot ] keep ;
+++ /dev/null
-Slot editor gadgets are used to implement the UI inspector
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax models
-ui.gadgets ui.gadgets.worlds ;
-IN: ui.gadgets.status-bar
-
-HELP: <status-bar>
-{ $values { "model" model } { "gadget" "a new " { $link gadget } } }
-{ $description "Creates a new " { $link gadget } " displaying the model value, which must be a string or " { $link f } "." }
-{ $notes "If the " { $snippet "model" } " is " { $link world-status } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ;
+++ /dev/null
-! Copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors models models.delay models.filter
-sequences ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks
-ui.gadgets.worlds ui.gadgets ui kernel calendar summary ;
-IN: ui.gadgets.status-bar
-
-: <status-bar> ( model -- gadget )
- 1/10 seconds <delay> [ "" like ] <filter> <label-control>
- reverse-video-theme
- t >>root? ;
-
-: open-status-window ( gadget title -- )
- f <model> [ <world> ] keep
- <status-bar> f track-add
- open-world-window ;
-
-: show-summary ( object gadget -- )
- >r [ summary ] [ "" ] if* r> show-status ;
+++ /dev/null
-Status bar gadgets display mouse-over help for other gadgets
+++ /dev/null
-Gadget hierarchy and layout management
+++ /dev/null
-William Schlieper
\ No newline at end of file
+++ /dev/null
-Tabbed windows
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: accessors kernel fry math math.vectors sequences arrays vectors assocs\r
- hashtables models models.range models.compose combinators\r
- ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs\r
- ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;\r
-\r
-IN: ui.gadgets.tabs\r
-\r
-TUPLE: tabbed < frame names toggler content ;\r
-\r
-DEFER: (del-page)\r
-\r
-:: add-toggle ( model n name toggler -- )\r
- <frame>\r
- n name toggler parent>> '[ , , , (del-page) ] "X" swap <bevel-button>\r
- @right grid-add\r
- n model name <toggle-button> @center grid-add\r
- toggler swap add-gadget drop ;\r
-\r
-: redo-toggler ( tabbed -- )\r
- [ names>> ] [ model>> ] [ toggler>> ] tri\r
- [ clear-gadget ] keep\r
- [ [ length ] keep ] 2dip\r
- '[ , _ _ , add-toggle ] 2each ;\r
-\r
-: refresh-book ( tabbed -- )\r
- model>> [ ] change-model ;\r
-\r
-: (del-page) ( n name tabbed -- )\r
- { [ [ remove ] change-names redo-toggler ]\r
- [ dupd [ names>> length ] [ model>> ] bi\r
- [ [ = ] keep swap [ 1- ] when\r
- [ < ] keep swap [ 1- ] when ] change-model ]\r
- [ content>> nth-gadget unparent ]\r
- [ refresh-book ]\r
- } cleave ;\r
-\r
-: add-page ( page name tabbed -- )\r
- [ names>> push ] 2keep\r
- [ [ model>> swap ]\r
- [ names>> length 1 - swap ]\r
- [ toggler>> ] tri add-toggle ]\r
- [ content>> swap add-gadget drop ]\r
- [ refresh-book ] tri ;\r
-\r
-: del-page ( name tabbed -- )\r
- [ names>> index ] 2keep (del-page) ;\r
-\r
-: <tabbed> ( assoc -- tabbed )\r
- tabbed new-frame\r
- 0 <model> >>model\r
- <pile> 1 >>fill >>toggler\r
- dup toggler>> @left grid-add\r
- swap\r
- [ keys >vector >>names ]\r
- [ values over model>> <book> >>content dup content>> @center grid-add ]\r
- bi\r
- dup redo-toggler ;\r
- \r
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Common colors and gradients used by the UI
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! Copyright (C) 2006, 2007 Alex Chapman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences io.styles ui.gadgets ui.render
-colors accessors ;
-IN: ui.gadgets.theme
-
-: solid-interior ( gadget color -- gadget )
- <solid> >>interior ; inline
-
-: solid-boundary ( gadget color -- gadget )
- <solid> >>boundary ; inline
-
-: faint-boundary ( gadget -- gadget )
- gray solid-boundary ; inline
-
-: selection-color ( -- color ) light-purple ;
-
-: plain-gradient
- T{ gradient f {
- T{ rgba f 0.94 0.94 0.94 1.0 }
- T{ rgba f 0.83 0.83 0.83 1.0 }
- T{ rgba f 0.83 0.83 0.83 1.0 }
- T{ rgba f 0.62 0.62 0.62 1.0 }
- } } ;
-
-: rollover-gradient
- T{ gradient f {
- T{ rgba f 1.0 1.0 1.0 1.0 }
- T{ rgba f 0.9 0.9 0.9 1.0 }
- T{ rgba f 0.9 0.9 0.9 1.0 }
- T{ rgba f 0.75 0.75 0.75 1.0 }
- } } ;
-
-: pressed-gradient
- T{ gradient f {
- T{ rgba f 0.75 0.75 0.75 1.0 }
- T{ rgba f 0.9 0.9 0.9 1.0 }
- T{ rgba f 0.9 0.9 0.9 1.0 }
- T{ rgba f 1.0 1.0 1.0 1.0 }
- } } ;
-
-: selected-gradient
- T{ gradient f {
- T{ rgba f 0.65 0.65 0.65 1.0 }
- T{ rgba f 0.8 0.8 0.8 1.0 }
- T{ rgba f 0.8 0.8 0.8 1.0 }
- T{ rgba f 1.0 1.0 1.0 1.0 }
- } } ;
-
-: lowered-gradient
- T{ gradient f {
- T{ rgba f 0.37 0.37 0.37 1.0 }
- T{ rgba f 0.43 0.43 0.43 1.0 }
- T{ rgba f 0.5 0.5 0.5 1.0 }
- } } ;
-
-: sans-serif-font { "sans-serif" plain 12 } ;
-
-: monospace-font { "monospace" plain 12 } ;
+++ /dev/null
-
-USING: kernel sequences math math.order
- ui.gadgets ui.gadgets.tracks ui.gestures
- fry accessors ;
-
-IN: ui.gadgets.tiling
-
-TUPLE: tiling < track gadgets tiles first focused ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-tiling ( tiling -- tiling )
- init-track
- { 1 0 } >>orientation
- V{ } clone >>gadgets
- 2 >>tiles
- 0 >>first
- 0 >>focused ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: <tiling> ( -- gadget ) tiling new init-tiling ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bounded-subseq ( seq a b -- seq )
- [ 0 max ] dip
- pick length [ min ] curry bi@
- rot
- subseq ;
-
-: tiling-gadgets-to-map ( tiling -- gadgets )
- [ gadgets>> ]
- [ first>> ]
- [ [ first>> ] [ tiles>> ] bi + ]
- tri
- bounded-subseq ;
-
-: tiling-map-gadgets ( tiling -- tiling )
- dup clear-track
- dup tiling-gadgets-to-map [ 1 track-add ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: tiling-add ( tiling gadget -- tiling )
- over gadgets>> push
- tiling-map-gadgets ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: first-gadget ( tiling -- index ) drop 0 ;
-
-: last-gadget ( tiling -- index ) gadgets>> length 1 - ;
-
-: first-viewable ( tiling -- index ) first>> ;
-
-: last-viewable ( tiling -- index ) [ first>> ] [ tiles>> ] bi + 1 - ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-focused-mapped ( tiling -- tiling )
-
- dup [ focused>> ] [ first>> ] bi <
- [ dup first>> 1 - >>first ]
- [ ]
- if
-
- dup [ last-viewable ] [ focused>> ] bi <
- [ dup first>> 1 + >>first ]
- [ ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: check-focused-bounds ( tiling -- tiling )
- dup focused>> 0 max over gadgets>> length 1 - min >>focused ;
-
-: focus-prev ( tiling -- tiling )
- dup focused>> 1 - >>focused
- check-focused-bounds
- make-focused-mapped
- tiling-map-gadgets
- dup request-focus ;
-
-: focus-next ( tiling -- tiling )
- dup focused>> 1 + >>focused
- check-focused-bounds
- make-focused-mapped
- tiling-map-gadgets
- dup request-focus ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: exchanged! ( seq a b -- )
- [ 0 max ] bi@
- pick length 1 - '[ , min ] bi@
- rot exchange ;
-
-: move-prev ( tiling -- tiling )
- dup [ gadgets>> ] [ focused>> 1 - ] [ focused>> ] tri exchanged!
- focus-prev ;
-
-: move-next ( tiling -- tiling )
- dup [ gadgets>> ] [ focused>> ] [ focused>> 1 + ] tri exchanged!
- focus-next ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: add-tile ( tiling -- tiling )
- dup tiles>> 1 + >>tiles
- tiling-map-gadgets ;
-
-: del-tile ( tiling -- tiling )
- dup tiles>> 1 - 1 max >>tiles
- tiling-map-gadgets ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: tiling focusable-child* ( tiling -- child/t )
- [ focused>> ] [ gadgets>> ] bi nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: tiling-shelf < tiling ;
-TUPLE: tiling-pile < tiling ;
-
-: <tiling-shelf> ( -- gadget )
- tiling-shelf new init-tiling { 1 0 } >>orientation ;
-
-: <tiling-pile> ( -- gadget )
- tiling-pile new init-tiling { 0 1 } >>orientation ;
-
-tiling-shelf
- H{
- { T{ key-down f { A+ } "LEFT" } [ focus-prev drop ] }
- { T{ key-down f { A+ } "RIGHT" } [ focus-next drop ] }
- { T{ key-down f { S+ A+ } "LEFT" } [ move-prev drop ] }
- { T{ key-down f { S+ A+ } "RIGHT" } [ move-next drop ] }
- { T{ key-down f { C+ } "[" } [ del-tile drop ] }
- { T{ key-down f { C+ } "]" } [ add-tile drop ] }
- }
-set-gestures
-
-tiling-pile
- H{
- { T{ key-down f { A+ } "UP" } [ focus-prev drop ] }
- { T{ key-down f { A+ } "DOWN" } [ focus-next drop ] }
- { T{ key-down f { S+ A+ } "UP" } [ move-prev drop ] }
- { T{ key-down f { S+ A+ } "DOWN" } [ move-next drop ] }
- { T{ key-down f { C+ } "[" } [ del-tile drop ] }
- { T{ key-down f { C+ } "]" } [ add-tile drop ] }
- }
-set-gestures
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Track gadgets arrange children horizontally or vertically, giving each child a specified fraction of total available space
+++ /dev/null
-USING: ui.gadgets.packs help.markup help.syntax ui.gadgets
-arrays kernel quotations classes.tuple ;
-IN: ui.gadgets.tracks
-
-ARTICLE: "ui-track-layout" "Track layouts"
-"Track gadgets are like " { $link "ui-pack-layout" } " except each child is resized to a fixed multiple of the track's dimension."
-{ $subsection track }
-"Creating empty tracks:"
-{ $subsection <track> }
-"Adding children:"
-{ $subsection track-add } ;
-
-HELP: track
-{ $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ;
-
-HELP: <track>
-{ $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }
-{ $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
-
-HELP: track-add
-{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
-{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;
-
-ABOUT: "ui-track-layout"
+++ /dev/null
-USING: kernel ui.gadgets ui.gadgets.tracks tools.test
- math.geometry.rect accessors ;
-IN: ui.gadgets.tracks.tests
-
-[ { 100 100 } ] [
- { 0 1 } <track>
- <gadget> { 100 100 } >>dim 1 track-add
- pref-dim
-] unit-test
-
-[ { 100 110 } ] [
- { 0 1 } <track>
- <gadget> { 10 10 } >>dim f track-add
- <gadget> { 100 100 } >>dim 1 track-add
- pref-dim
-] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io kernel math namespaces
- sequences words math.vectors ui.gadgets ui.gadgets.packs
- math.geometry.rect fry ;
-
-IN: ui.gadgets.tracks
-
-TUPLE: track < pack sizes ;
-
-: normalized-sizes ( track -- seq )
- sizes>> dup sift sum '[ dup [ , / ] when ] map ;
-
-: init-track ( track -- track )
- init-gadget
- V{ } clone >>sizes
- 1 >>fill ;
-
-: new-track ( orientation class -- track )
- new
- init-track
- swap >>orientation ;
-
-: <track> ( orientation -- track ) track new-track ;
-
-: alloted-dim ( track -- dim )
- [ children>> ] [ sizes>> ] bi { 0 0 }
- [ [ drop { 0 0 } ] [ pref-dim ] if v+ ] 2reduce ;
-
-: available-dim ( track -- dim ) [ dim>> ] [ alloted-dim ] bi v- ;
-
-: track-layout ( track -- sizes )
- [ available-dim ] [ children>> ] [ normalized-sizes ] tri
- [ [ over n*v ] [ pref-dim ] ?if ] 2map nip ;
-
-M: track layout* ( track -- ) dup track-layout pack-layout ;
-
-: track-pref-dims-1 ( track -- dim ) children>> pref-dims max-dim ;
-
-: track-pref-dims-2 ( track -- dim )
- [ children>> pref-dims ] [ normalized-sizes ] bi
- [ [ v/n ] when* ] 2map
- max-dim
- [ >fixnum ] map ;
-
-M: track pref-dim* ( gadget -- dim )
- [ track-pref-dims-1 ]
- [ [ alloted-dim ] [ track-pref-dims-2 ] bi v+ ]
- [ orientation>> ]
- tri
- set-axis ;
-
-: track-add ( track gadget constraint -- track )
- pick sizes>> push add-gadget ;
-
-: track-remove ( track gadget -- track )
- dupd dup
- [
- [ swap children>> index ]
- [ unparent sizes>> ] 2bi
- delete-nth
- ]
- [ 2drop ]
- if ;
-
-: clear-track ( track -- ) V{ } clone >>sizes clear-gadget ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Viewport gadgets display a portion of a child gadget and are used to implement scrollers
+++ /dev/null
-USING: help.markup help.syntax ui.gadgets models ;
-IN: ui.gadgets.viewports
-
-HELP: viewport
-{ $class-description "A viewport is a control which positions a child gadget translated by the " { $link control-value } " vector. Viewports can be created directly by calling " { $link <viewport> } "." } ;
-
-HELP: <viewport>
-{ $values { "content" gadget } { "model" model } { "viewport" "a new " { $link viewport } } }
-{ $description "Creates a new " { $link viewport } " containing " { $snippet "content" } "." } ;
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: ui.gadgets.viewports
-USING: accessors arrays ui.gadgets ui.gadgets.borders
-kernel math namespaces sequences models math.vectors math.geometry.rect ;
-
-: viewport-gap { 3 3 } ; inline
-
-TUPLE: viewport < gadget ;
-
-: find-viewport ( gadget -- viewport )
- [ viewport? ] find-parent ;
-
-: viewport-dim ( viewport -- dim )
- gadget-child pref-dim viewport-gap 2 v*n v+ ;
-
-: <viewport> ( content model -- viewport )
- viewport new-gadget
- swap >>model
- t >>clipped?
- [ swap add-gadget drop ] keep ;
-
-M: viewport layout*
- dup rect-dim viewport-gap 2 v*n v-
- over gadget-child pref-dim vmax
- swap gadget-child (>>dim) ;
-
-M: viewport focusable-child*
- gadget-child ;
-
-M: viewport pref-dim* viewport-dim ;
-
-: scroller-value ( scroller -- loc )
- gadget-model range-value [ >fixnum ] map ;
-
-M: viewport model-changed
- nip
- dup relayout-1
- dup scroller-value
- vneg viewport-gap v+
- swap gadget-child set-rect-loc ;
-
-: visible-dim ( gadget -- dim )
- dup gadget-parent viewport? [
- gadget-parent rect-dim viewport-gap 2 v*n v-
- ] [
- rect-dim
- ] if ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-World gadgets are the top level of the gadget hierarchy and are displayed in native windows
+++ /dev/null
-USING: ui.gadgets ui.render ui.gestures ui.backend help.markup
-help.syntax models opengl strings ;
-IN: ui.gadgets.worlds
-
-HELP: origin
-{ $var-description "Within the dynamic extent of " { $link draw-world } ", holds the co-ordinate system origin for the gadget currently being drawn." } ;
-
-HELP: hand-world
-{ $var-description "Global variable. The " { $link world } " containing the gadget at the mouse location." } ;
-
-HELP: set-title
-{ $values { "string" string } { "world" world } }
-{ $description "Sets the title bar of the native window containing the world." }
-{ $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ;
-
-HELP: select-gl-context
-{ $values { "handle" "a backend-specific handle" } }
-{ $description "Selects an OpenGL context to be the implicit destination for subsequent GL rendering calls. This word is called automatically by the UI before drawing a " { $link world } "." } ;
-
-HELP: flush-gl-context
-{ $values { "handle" "a backend-specific handle" } }
-{ $description "Ensures all GL rendering calls made to an OpenGL context finish rendering to the screen. This word is called automatically by the UI after drawing a " { $link world } "." } ;
-
-HELP: focus-path
-{ $values { "world" world } { "seq" "a new sequence" } }
-{ $description "If the top-level window containing the world has focus, outputs a sequence of parents of the currently focused gadget, otherwise outputs " { $link f } "." }
-{ $notes "This word is used to avoid sending " { $link gain-focus } " gestures to a gadget which requests focus on an unfocused top-level window, so that, for instance, a text editing caret does not appear in this case." } ;
-
-HELP: world
-{ $class-description "A gadget which appears at the top of the gadget hieararchy, and in turn may be displayed in a native window. Worlds have the following slots:"
- { $list
- { { $snippet "active?" } " - if set to " { $link f } ", the world will not be drawn. This slot is set to " { $link f } " if an error is thrown while drawing the world; this prevents multiple debugger windows from being shown." }
- { { $snippet "glass" } " - a glass pane in front of the primary gadget, used to implement behaviors such as popup menus which are hidden when the mouse is clicked outside the menu." }
- { { $snippet "title" } " - a string to be displayed in the title bar of the native window containing the world." }
- { { $snippet "status" } " - a " { $link model } " holding a string to be displayed in the world's status bar." }
- { { $snippet "focus" } " - the current owner of the keyboard focus in the world." }
- { { $snippet "focused?" } " - a boolean indicating if the native window containing the world has keyboard focus." }
- { { $snippet "fonts" } " - a hashtable mapping font instances to vectors of " { $link sprite } " instances." }
- { { $snippet "handle" } " - a backend-specific native handle representing the native window containing the world, or " { $link f } " if the world is not grafted." }
- { { $snippet "window-loc" } " - the on-screen location of the native window containing the world. The co-ordinate system here is backend-specific." }
- }
-} ;
-
-HELP: <world>
-{ $values { "gadget" gadget } { "title" string } { "status" model } { "world" "a new " { $link world } } }
-{ $description "Creates a new " { $link world } " delegating to the given gadget." } ;
-
-HELP: find-world
-{ $values { "gadget" gadget } { "world" "a " { $link world } " or " { $link f } } }
-{ $description "Finds the " { $link world } " containing the gadget, or outputs " { $link f } " if the gadget is not grafted." } ;
-
-HELP: draw-world
-{ $values { "world" world } }
-{ $description "Redraws a world." }
-{ $notes "This word should only be called by the UI backend. To force a gadget to redraw from user code, call " { $link relayout-1 } "." } ;
+++ /dev/null
-IN: ui.gadgets.worlds.tests
-USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
-namespaces models kernel ;
-
-! Test focus behavior
-<gadget> "g1" set
-
-: <test-world> ( gadget -- world )
- "Hi" f <world> ;
-
-[ ] [
- "g1" get <test-world> "w" set
-] unit-test
-
-[ ] [ "g1" get request-focus ] unit-test
-
-[ t ] [ "w" get gadget-focus "g1" get eq? ] unit-test
-
-<gadget> "g1" set
-<gadget> "g2" set
-"g1" get "g2" get swap add-gadget drop
-
-[ ] [
- "g2" get <test-world> "w" set
-] unit-test
-
-[ ] [ "g1" get request-focus ] unit-test
-
-[ t ] [ "w" get gadget-focus "g2" get eq? ] unit-test
-[ t ] [ "g2" get gadget-focus "g1" get eq? ] unit-test
-[ f ] [ "g1" get gadget-focus ] unit-test
-
-<gadget> "g1" set
-<gadget> "g2" set
-<gadget> "g3" set
-"g1" get "g3" get swap add-gadget drop
-"g2" get "g3" get swap add-gadget drop
-
-[ ] [
- "g3" get <test-world> "w" set
-] unit-test
-
-[ ] [ "g1" get request-focus ] unit-test
-[ ] [ "g2" get unparent ] unit-test
-[ t ] [ "g3" get gadget-focus "g1" get eq? ] unit-test
-
-[ t ] [ <gadget> dup <test-world> focusable-child eq? ] unit-test
-
-TUPLE: focusing < gadget ;
-
-: <focusing>
- focusing new-gadget ;
-
-TUPLE: focus-test < gadget ;
-
-: <focus-test>
- focus-test new-gadget
- <focusing> over swap add-gadget drop ;
-
-M: focus-test focusable-child* gadget-child ;
-
-<focus-test> "f" set
-
-[ ] [ "f" get <test-world> request-focus ] unit-test
-
-[ t ] [ "f" get gadget-focus "f" get gadget-child eq? ] unit-test
-
-[ t ] [ "f" get gadget-child focusing? ] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs continuations kernel math models
-namespaces opengl sequences io combinators math.vectors
-ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-debugger math.geometry.rect ;
-IN: ui.gadgets.worlds
-
-TUPLE: world < track
-active? focused?
-glass
-title status
-fonts handle
-window-loc ;
-
-: find-world ( gadget -- world ) [ world? ] find-parent ;
-
-M: f world-status ;
-
-: show-status ( string/f gadget -- )
- find-world world-status [ set-model ] [ drop ] if* ;
-
-: hide-status ( gadget -- ) f swap show-status ;
-
-: (request-focus) ( child world ? -- )
- pick gadget-parent pick eq? [
- >r >r dup gadget-parent dup r> r>
- [ (request-focus) ] keep
- ] unless focus-child ;
-
-M: world request-focus-on ( child gadget -- )
- 2dup eq?
- [ 2drop ] [ dup world-focused? (request-focus) ] if ;
-
-: <world> ( gadget title status -- world )
- { 0 1 } world new-track
- t >>root?
- t >>active?
- H{ } clone >>fonts
- { 0 0 } >>window-loc
- swap >>status
- swap >>title
- swap 1 track-add
- dup request-focus ;
-
-M: world layout*
- dup call-next-method
- dup world-glass [
- >r dup rect-dim r> (>>dim)
- ] when* drop ;
-
-M: world focusable-child* gadget-child ;
-
-M: world children-on nip gadget-children ;
-
-: (draw-world) ( world -- )
- dup world-handle [
- [ dup init-gl ] keep draw-gadget
- ] with-gl-context ;
-
-: draw-world? ( world -- ? )
- #! We don't draw deactivated worlds, or those with 0 size.
- #! On Windows, the latter case results in GL errors.
- dup world-active?
- over world-handle
- rot rect-dim [ 0 > ] all? and and ;
-
-TUPLE: world-error error world ;
-
-C: <world-error> world-error
-
-SYMBOL: ui-error-hook
-
-: ui-error ( error -- )
- ui-error-hook get [ call ] [ print-error ] if* ;
-
-[ rethrow ] ui-error-hook set-global
-
-: draw-world ( world -- )
- dup draw-world? [
- dup world [
- [
- (draw-world)
- ] [
- over <world-error> ui-error
- f swap set-world-active?
- ] recover
- ] with-variable
- ] [
- drop
- ] if ;
-
-world H{
- { T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] }
- { T{ key-down f { C+ } "c" } [ T{ copy-action } send-action ] }
- { T{ key-down f { C+ } "v" } [ T{ paste-action } send-action ] }
- { T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] }
- { T{ button-down f { C+ } 1 } [ T{ button-down f f 3 } swap resend-button-down ] }
- { T{ button-down f { A+ } 1 } [ T{ button-down f f 2 } swap resend-button-down ] }
- { T{ button-up f { C+ } 1 } [ T{ button-up f f 3 } swap resend-button-up ] }
- { T{ button-up f { A+ } 1 } [ T{ button-up f f 2 } swap resend-button-up ] }
-} set-gestures
-
-: close-global ( world global -- )
- dup get-global find-world rot eq?
- [ f swap set-global ] [ drop ] if ;
+++ /dev/null
-! 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 ;
-
-: <wrapper> ( child -- border ) wrapper new-wrapper ;
-
-M: wrapper pref-dim* ( wrapper -- dim ) gadget-child pref-dim ;
-
-M: wrapper layout* ( wrapper -- ) [ dim>> ] [ gadget-child ] bi (>>dim) ;
-
-M: wrapper focusable-child* ( wrapper -- child/t ) gadget-child ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets help.markup help.syntax hashtables
-strings kernel system ;
-IN: ui.gestures
-
-HELP: set-gestures
-{ $values { "class" "a class word" } { "hash" hashtable } }
-{ $description "Sets the gestures a gadget class responds to. The hashtable maps gestures to quotations with stack effect " { $snippet "( gadget -- )" } "." } ;
-
-HELP: handle-gesture*
-{ $values { "gadget" "the receiver of the gesture" } { "gesture" "a gesture" } { "delegate" "an object" } { "?" "a boolean" } }
-{ $contract "Handles a gesture sent to a gadget. As the delegation chain is traversed, this generic word is called with every delegate of the gadget at the top of the stack, however the front-most delegate remains fixed as the " { $snippet "gadget" } " parameter."
-$nl
-"Outputs " { $link f } " if the gesture was handled, and " { $link t } " if the gesture should be passed on to the gadget's delegate." }
-{ $notes "Methods should be defined on this word if you desire to handle an arbitrary set of gestures. To define handlers for a fixed set, it is easier to use " { $link set-gestures } "." } ;
-
-HELP: handle-gesture
-{ $values { "gesture" "a gesture" } { "gadget" gadget } { "?" "a boolean" } }
-{ $description "Calls " { $link handle-gesture* } " on every delegate of " { $snippet "gadget" } ". Outputs " { $link f } " if some delegate handled the gesture, else outputs " { $link t } "." } ;
-
-{ send-gesture handle-gesture handle-gesture* set-gestures } related-words
-
-HELP: send-gesture
-{ $values { "gesture" "a gesture" } { "gadget" gadget } { "?" "a boolean" } }
-{ $description "Calls " { $link send-gesture } " on every parent of " { $snippet "gadget" } ". Outputs " { $link f } " if some parent handled the gesture, else outputs " { $link t } "." } ;
-
-HELP: user-input
-{ $values { "str" string } { "gadget" gadget } }
-{ $description "Calls " { $link user-input* } " on every parent of the gadget." } ;
-
-HELP: motion
-{ $class-description "Mouse motion gesture." }
-{ $examples { $code "T{ motion }" } } ;
-
-HELP: drag
-{ $class-description "Mouse drag gesture. The " { $link drag-# } " slot is either set to a mouse button number, or " { $link f } " indicating no specific button is expected." } ;
-
-HELP: button-up
-{ $class-description "Mouse button up gesture. Instances have two slots:"
- { $list
- { { $link button-up-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
- { { $link button-up-# } " - a mouse button number, or " { $link f } " indicating no specific button is expected" }
- }
-}
-{ $examples { $code "T{ button-up f f 1 }" "T{ button-up }" } } ;
-
-HELP: button-down
-{ $class-description "Mouse button down gesture. Instances have two slots:"
- { $list
- { { $link button-down-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
- { { $link button-down-# } " - a mouse button number, or " { $link f } " indicating no specific button is expected" }
- }
-}
-{ $examples { $code "T{ button-down f f 1 }" "T{ button-down }" } } ;
-
-HELP: mouse-scroll
-{ $class-description "Scroll wheel motion gesture. When this gesture is sent, the " { $link scroll-direction } " global variable is set to a direction vector." }
-{ $examples { $code "T{ mouse-scroll }" } } ;
-
-HELP: mouse-enter
-{ $class-description "Gesture sent when the mouse enters the bounds of a gadget." }
-{ $examples { $code "T{ mouse-enter }" } } ;
-
-HELP: mouse-leave
-{ $class-description "Gesture sent when the mouse leaves the bounds of a gadget." }
-{ $examples { $code "T{ mouse-leave }" } } ;
-
-HELP: gain-focus
-{ $class-description "Gesture sent when a gadget gains keyboard focus." }
-{ $examples { $code "T{ gain-focus }" } } ;
-
-HELP: lose-focus
-{ $class-description "Gesture sent when a gadget loses keyboard focus." }
-{ $examples { $code "T{ lose-focus }" } } ;
-
-HELP: cut-action
-{ $class-description "Gesture sent when the " { $emphasis "cut" } " standard window system action is invoked." }
-{ $examples { $code "T{ cut-action }" } } ;
-
-HELP: copy-action
-{ $class-description "Gesture sent when the " { $emphasis "copy" } " standard window system action is invoked." }
-{ $examples { $code "T{ copy-action }" } } ;
-
-HELP: paste-action
-{ $class-description "Gesture sent when the " { $emphasis "paste" } " standard window system action is invoked." }
-{ $examples { $code "T{ paste-action }" } } ;
-
-HELP: delete-action
-{ $class-description "Gesture sent when the " { $emphasis "delete" } " standard window system action is invoked." }
-{ $examples { $code "T{ delete-action }" } } ;
-
-HELP: select-all-action
-{ $class-description "Gesture sent when the " { $emphasis "select all" } " standard window system action is invoked." }
-{ $examples { $code "T{ select-all-action }" } } ;
-
-HELP: generalize-gesture
-{ $values { "gesture" "a gesture" } { "newgesture" "a new gesture" } }
-{ $description "Turns a " { $link button-down } ", " { $link button-up } " or " { $link drag } " action naming a specific mouse button into one which can apply regardless of which mouse button was pressed." } ;
-
-HELP: C+
-{ $description "Control key modifier." } ;
-
-HELP: A+
-{ $description "Alt key modifier." } ;
-
-HELP: M+
-{ $description "Meta key modifier. This is the Command key on Mac OS X." } ;
-
-HELP: S+
-{ $description "Shift key modifier." } ;
-
-HELP: key-down
-{ $class-description "Key down gesture. Instances have two slots:"
- { $list
- { { $link key-down-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
- { { $link key-down-sym } " - a string denoting the key pressed; see " { $link "keyboard-gestures" } }
- }
-}
-{ $examples { $code "T{ key-down f { C+ } \"a\" }" "T{ key-down f f \"TAB\" }" } } ;
-
-HELP: key-up
-{ $class-description "Key up gesture. Instances have two slots:"
- { $list
- { { $link key-up-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
- { { $link key-up-sym } " - a string denoting the key pressed; see " { $link "keyboard-gestures" } }
- }
-}
-{ $examples { $code "T{ key-up f { C+ } \"a\" }" "T{ key-up f f \"TAB\" }" } } ;
-
-HELP: hand-gadget
-{ $var-description "Global variable. The gadget at the mouse location." } ;
-
-HELP: hand-loc
-{ $var-description "Global variable. The mouse location relative to the top-left corner of the " { $link hand-world } "." } ;
-
-{ hand-loc hand-rel } related-words
-
-HELP: hand-clicked
-{ $var-description "Global variable. The gadget at the location of the most recent click." } ;
-
-HELP: hand-click-loc
-{ $var-description "Global variable. The mouse location at the time of the most recent click relative to the top-left corner of the " { $link hand-world } "." } ;
-
-{ hand-clicked hand-click-loc } related-words
-
-HELP: hand-click#
-{ $var-description "Global variable. The number of times the mouse was clicked in short succession. This counter is reset when " { $link double-click-timeout } " expires." } ;
-
-HELP: hand-last-button
-{ $var-description "Global variable. The mouse button most recently pressed." } ;
-
-HELP: hand-last-time
-{ $var-description "Global variable. The timestamp of the most recent mouse button click. This timestamp has the same format as the output value of " { $link millis } "." } ;
-
-HELP: hand-buttons
-{ $var-description "Global variable. A vector of mouse buttons currently held down." } ;
-
-HELP: scroll-direction
-{ $var-description "Global variable. If the most recent gesture was a " { $link mouse-scroll } ", this holds a pair of integers indicating the direction of the scrolling as a two-dimensional vector." } ;
-
-HELP: double-click-timeout
-{ $var-description "Global variable. The maximum delay between two button presses which will still increment " { $link hand-click# } "." } ;
-
-HELP: button-gesture
-{ $values { "gesture" "a gesture" } }
-{ $description "Sends a gesture to the most recently clicked gadget, and if the gadget does not respond to the gesture, removes specific button number information from the gesture and sends it again." } ;
-
-HELP: fire-motion
-{ $description "Sends a " { $link motion } " or " { $link drag } " gesture to the gadget under the mouse, depending on whether a mouse button is being held down or not." } ;
-
-HELP: forget-rollover
-{ $description "Sends " { $link mouse-leave } " gestures to all gadgets containing the gadget under the mouse, and resets the " { $link hand-gadget } " variable." } ;
-
-HELP: request-focus
-{ $values { "gadget" gadget } }
-{ $description "Gives keyboard focus to the " { $link focusable-child } " of the gadget. This may result in " { $link lose-focus } " and " { $link gain-focus } " gestures being sent." } ;
-
-HELP: drag-loc
-{ $values { "loc" "a pair of integers" } }
-{ $description "Outputs the distance travelled by the mouse since the most recent press. Only meaningful inside a " { $link drag } " gesture handler." } ;
-
-HELP: hand-rel
-{ $values { "gadget" gadget } { "loc" "a pair of integers" } }
-{ $description "Outputs the location of the mouse relative to the top-left corner of the gadget. Only meaningful inside a " { $link button-down } ", " { $link button-up } ", " { $link motion } " or " { $link drag } " gesture handler, where the gadget is contained in the same world as the gadget receiving the gesture." } ;
-
-HELP: hand-click-rel
-{ $values { "gadget" gadget } { "loc" "a pair of integers" } }
-{ $description "Outputs the location of the last mouse relative to the top-left corner of the gadget. Only meaningful inside a " { $link button-down } ", " { $link button-up } ", " { $link motion } " or " { $link drag } " gesture handler, where the gadget is contained in the same world as the gadget receiving the gesture." } ;
-
-HELP: under-hand
-{ $values { "seq" "a new sequence" } }
-{ $description "Outputs a sequence where the first element is the " { $link hand-world } " and the last is the " { $link hand-gadget } ", with all parents in between." } ;
-
-HELP: gesture>string
-{ $values { "gesture" "a gesture" } { "string/f" "a " { $link string } " or " { $link f } } }
-{ $contract "Creates a human-readable string from a gesture object, returning " { $link f } " if the gesture does not have a human-readable form." }
-{ $examples
- { $example "USING: io ui.gestures ;" "T{ key-down f { C+ } \"x\" } gesture>string print" "C+x" }
-} ;
-
-ARTICLE: "ui-gestures" "UI gestures"
-"User actions such as keyboard input and mouse button clicks deliver " { $emphasis "gestures" } " to gadgets. If the direct receiver of the gesture does not handle it, the gesture is passed on to the receiver's parent, and this way it travels up the gadget hierarchy. Gestures which are not handled at some point are ignored."
-$nl
-"There are two ways to define gesture handling logic. The simplest way is to associate a fixed set of gestures with a class:"
-{ $subsection set-gestures }
-"Another way is to define a generic word on a class which handles all gestures sent to gadgets of that class:"
-{ $subsection handle-gesture* }
-"Sometimes a gesture needs to be presented to the user:"
-{ $subsection gesture>string }
-"Keyboard input:"
-{ $subsection "ui-focus" }
-{ $subsection "keyboard-gestures" }
-{ $subsection "action-gestures" }
-{ $subsection "ui-user-input" }
-"Mouse input:"
-{ $subsection "mouse-gestures" }
-"Abstractions built on top of gestures:"
-{ $subsection "ui-commands" }
-{ $subsection "ui-operations" } ;
-
-ARTICLE: "ui-focus" "Keyboard focus"
-"The gadget with keyboard focus is the current receiver of keyboard gestures and user input. Gadgets that wish to receive keyboard input should request focus when clicked:"
-{ $subsection request-focus }
-"The following example demonstrates defining a handler for a mouse click gesture which requests focus:"
-{ $code
- "my-gadget H{"
- " { T{ button-down } [ request-focus ] }"
- "} set-gestures"
-}
-"To nominate a single child as the default focusable child, implement a method on a generic word:"
-{ $subsection focusable-child* }
-"Gestures are sent to a gadget when it gains or loses focus; this can be used to change the gadget's appearance, for example by displaying a border:"
-{ $subsection gain-focus }
-{ $subsection lose-focus } ;
-
-ARTICLE: "keyboard-gestures" "Keyboard gestures"
-"There are two types of keyboard gestures:"
-{ $subsection key-down }
-{ $subsection key-up }
-"Each keyboard gesture has a set of modifiers and a key symbol. The set modifiers is denoted by an array which must either be " { $link f } ", or an order-preserving subsequence of the following:"
-{ $code "{ S+ C+ A+ M+ }" }
-{ $subsection S+ }
-{ $subsection C+ }
-{ $subsection A+ }
-{ $subsection M+ }
-"A key symbol is either a single-character string denoting literal input, or one of the following strings:"
-{ $list
- { $snippet "CLEAR" }
- { $snippet "RET" }
- { $snippet "ENTER" }
- { $snippet "ESC" }
- { $snippet "TAB" }
- { $snippet "BACKSPACE" }
- { $snippet "HOME" }
- { $snippet "DELETE" }
- { $snippet "END" }
- { $snippet "F1" }
- { $snippet "F2" }
- { $snippet "F3" }
- { $snippet "F4" }
- { $snippet "F5" }
- { $snippet "F6" }
- { $snippet "F7" }
- { $snippet "F8" }
- { $snippet "LEFT" }
- { $snippet "RIGHT" }
- { $snippet "DOWN" }
- { $snippet "UP" }
- { $snippet "PAGE_UP" }
- { $snippet "PAGE_DOWN" }
-}
-"The " { $link S+ } " modifier is only ever used with the above action keys; alphanumeric input input with the shift key is delivered without the " { $link S+ } " modifier set, instead the input itself is upper case. For example, the gesture corresponding to " { $snippet "s" } " with the Control and Shift keys pressed is presented as "
-{ $code "T{ key-down f { C+ } \"S\" }" }
-"The " { $snippet "RET" } ", " { $snippet "TAB" } " and " { $snippet "SPACE" } " keys are never delivered in their literal form (" { $snippet "\"\\n\"" } ", " { $snippet "\"\\t\"" } " or " { $snippet "\" \"" } ")." ;
-
-ARTICLE: "ui-user-input" "Free-form keyboard input"
-"Whereas keyboard gestures are intended to be used for keyboard shortcuts, certain gadgets such as text fields need to accept free-form keyboard input. This can be done by implementing a generic word:"
-{ $subsection user-input* } ;
-
-ARTICLE: "mouse-gestures" "Mouse gestures"
-"There are two types of mouse gestures indicating button clicks:"
-{ $subsection button-down }
-{ $subsection button-up }
-"When a mouse button is pressed or released, two gestures are sent. The first gesture indicates the specific button number, and if this gesture is not handled, the second has a button number set to " { $link f } ":"
-{ $code "T{ button-down f 1 }" "T{ button-down f f }" }
-"Because tuple literals fill unspecified slots with " { $link f } ", the last gesture can be written as " { $snippet "T{ button-down }" } "."
-$nl
-"Gestures to indicate mouse motion, depending on whenever a button is held down or not:"
-{ $subsection motion }
-{ $subsection drag }
-"Gestures to indicate that the mouse has crossed gadget boundaries:"
-{ $subsection mouse-enter }
-{ $subsection mouse-leave }
-"A number of global variables are set after a mouse gesture is sent. These variables can be read to obtain additional information about the gesture."
-{ $subsection hand-gadget }
-{ $subsection hand-world }
-{ $subsection hand-loc }
-{ $subsection hand-buttons }
-{ $subsection hand-clicked }
-{ $subsection hand-click-loc }
-{ $subsection hand-click# }
-"There are some utility words for working with click locations:"
-{ $subsection hand-rel }
-{ $subsection hand-click-rel }
-{ $subsection drag-loc }
-"Mouse scroll wheel gesture:"
-{ $subsection mouse-scroll }
-"Global variable set when a mouse scroll wheel gesture is sent:"
-{ $subsection scroll-direction } ;
-
-ARTICLE: "action-gestures" "Action gestures"
-"Action gestures exist to keep keyboard shortcuts for common clipboard operations consistent."
-{ $subsection cut-action }
-{ $subsection copy-action }
-{ $subsection paste-action }
-{ $subsection delete-action }
-{ $subsection select-all-action }
-"The following keyboard gestures, if not handled directly, send action gestures:"
-{ $table
- { { $strong "Keyboard gesture" } { $strong "Action gesture" } }
- { { $snippet "T{ key-down f { C+ } \"x\" }" } { $snippet "T{ cut-action }" } }
- { { $snippet "T{ key-down f { C+ } \"c\" }" } { $snippet "T{ copy-action }" } }
- { { $snippet "T{ key-down f { C+ } \"v\" }" } { $snippet "T{ paste-action }" } }
- { { $snippet "T{ key-down f { C+ } \"a\" }" } { $snippet "T{ select-all }" } }
-}
-"Action gestures should be used in place of the above keyboard gestures if possible. For example, on Mac OS X, the standard " { $strong "Edit" } " menu items send action gestures." ;
-
-ABOUT: "ui-gestures"
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs kernel math models namespaces
-sequences words strings system hashtables math.parser
-math.vectors classes.tuple classes ui.gadgets boxes
-calendar alarms symbols combinators sets columns ;
-IN: ui.gestures
-
-: set-gestures ( class hash -- ) "gestures" set-word-prop ;
-
-GENERIC: handle-gesture* ( gadget gesture delegate -- ? )
-
-: default-gesture-handler ( gadget gesture delegate -- ? )
- class superclasses [ "gestures" word-prop ] map assoc-stack dup
- [ call f ] [ 2drop t ] if ;
-
-M: object handle-gesture* default-gesture-handler ;
-
-: handle-gesture ( gesture gadget -- ? )
- tuck delegates [ >r 2dup r> handle-gesture* ] all? 2nip ;
-
-: send-gesture ( gesture gadget -- ? )
- [ dupd handle-gesture ] each-parent nip ;
-
-: user-input ( str gadget -- )
- over empty?
- [ [ dupd user-input* ] each-parent ] unless
- 2drop ;
-
-! Gesture objects
-TUPLE: motion ; C: <motion> motion
-TUPLE: drag # ; C: <drag> drag
-TUPLE: button-up mods # ; C: <button-up> button-up
-TUPLE: button-down mods # ; C: <button-down> button-down
-TUPLE: mouse-scroll ; C: <mouse-scroll> mouse-scroll
-TUPLE: mouse-enter ; C: <mouse-enter> mouse-enter
-TUPLE: mouse-leave ; C: <mouse-leave> mouse-leave
-TUPLE: lose-focus ; C: <lose-focus> lose-focus
-TUPLE: gain-focus ; C: <gain-focus> gain-focus
-
-! Higher-level actions
-TUPLE: cut-action ; C: <cut-action> cut-action
-TUPLE: copy-action ; C: <copy-action> copy-action
-TUPLE: paste-action ; C: <paste-action> paste-action
-TUPLE: delete-action ; C: <delete-action> delete-action
-TUPLE: select-all-action ; C: <select-all-action> select-all-action
-
-TUPLE: left-action ; C: <left-action> left-action
-TUPLE: right-action ; C: <right-action> right-action
-TUPLE: up-action ; C: <up-action> up-action
-TUPLE: down-action ; C: <down-action> down-action
-
-TUPLE: zoom-in-action ; C: <zoom-in-action> zoom-in-action
-TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
-
-: generalize-gesture ( gesture -- newgesture )
- clone f >># ;
-
-! Modifiers
-SYMBOLS: C+ A+ M+ S+ ;
-
-TUPLE: key-down mods sym ;
-
-: <key-gesture> ( mods sym action? class -- mods' sym' )
- >r [ S+ rot remove swap ] unless r> boa ; inline
-
-: <key-down> ( mods sym action? -- key-down )
- key-down <key-gesture> ;
-
-TUPLE: key-up mods sym ;
-
-: <key-up> ( mods sym action? -- key-up )
- key-up <key-gesture> ;
-
-! Hand state
-
-! Note that these are only really useful inside an event
-! handler, and that the locations hand-loc and hand-click-loc
-! are in the co-ordinate system of the world which contains
-! the gadget in question.
-SYMBOL: hand-gadget
-SYMBOL: hand-world
-SYMBOL: hand-loc
-{ 0 0 } hand-loc set-global
-
-SYMBOL: hand-clicked
-SYMBOL: hand-click-loc
-SYMBOL: hand-click#
-SYMBOL: hand-last-button
-SYMBOL: hand-last-time
-0 hand-last-button set-global
-0 hand-last-time set-global
-
-SYMBOL: hand-buttons
-V{ } clone hand-buttons set-global
-
-SYMBOL: scroll-direction
-{ 0 0 } scroll-direction set-global
-
-SYMBOL: double-click-timeout
-300 double-click-timeout set-global
-
-: hand-moved? ( -- ? )
- hand-loc get hand-click-loc get = not ;
-
-: button-gesture ( gesture -- )
- hand-clicked get-global 2dup send-gesture [
- >r generalize-gesture r> send-gesture drop
- ] [
- 2drop
- ] if ;
-
-: drag-gesture ( -- )
- hand-buttons get-global
- dup empty? [ drop ] [ first <drag> button-gesture ] if ;
-
-SYMBOL: drag-timer
-
-<box> drag-timer set-global
-
-: start-drag-timer ( -- )
- hand-buttons get-global empty? [
- [ drag-gesture ]
- 300 milliseconds hence
- 100 milliseconds
- add-alarm drag-timer get-global >box
- ] when ;
-
-: stop-drag-timer ( -- )
- hand-buttons get-global empty? [
- drag-timer get-global ?box
- [ cancel-alarm ] [ drop ] if
- ] when ;
-
-: fire-motion ( -- )
- hand-buttons get-global empty? [
- T{ motion } hand-gadget get-global send-gesture drop
- ] [
- drag-gesture
- ] if ;
-
-: each-gesture ( gesture seq -- )
- [ handle-gesture drop ] with each ;
-
-: hand-gestures ( new old -- )
- drop-prefix <reversed>
- T{ mouse-leave } swap each-gesture
- T{ mouse-enter } swap each-gesture ;
-
-: forget-rollover ( -- )
- f hand-world set-global
- hand-gadget get-global >r
- f hand-gadget set-global
- f r> parents hand-gestures ;
-
-: send-lose-focus ( gadget -- )
- T{ lose-focus } swap handle-gesture drop ;
-
-: send-gain-focus ( gadget -- )
- T{ gain-focus } swap handle-gesture drop ;
-
-: focus-child ( child gadget ? -- )
- [
- dup gadget-focus [
- dup send-lose-focus
- f swap t focus-child
- ] when*
- dupd set-gadget-focus [
- send-gain-focus
- ] when*
- ] [
- set-gadget-focus
- ] if ;
-
-: modifier ( mod modifiers -- seq )
- [ second swap bitand 0 > ] with filter
- 0 <column> prune dup empty? [ drop f ] [ >array ] if ;
-
-: drag-loc ( -- loc )
- hand-loc get-global hand-click-loc get-global v- ;
-
-: hand-rel ( gadget -- loc )
- hand-loc get-global swap screen-loc v- ;
-
-: hand-click-rel ( gadget -- loc )
- hand-click-loc get-global swap screen-loc v- ;
-
-: multi-click-timeout? ( -- ? )
- millis hand-last-time get - double-click-timeout get <= ;
-
-: multi-click-button? ( button -- button ? )
- dup hand-last-button get = ;
-
-: multi-click-position? ( -- ? )
- hand-loc get hand-click-loc get v- norm-sq 100 <= ;
-
-: multi-click? ( button -- ? )
- {
- { [ multi-click-timeout? not ] [ f ] }
- { [ multi-click-button? not ] [ f ] }
- { [ multi-click-position? not ] [ f ] }
- { [ multi-click-position? not ] [ f ] }
- [ t ]
- } cond nip ;
-
-: update-click# ( button -- )
- global [
- dup multi-click? [
- hand-click# inc
- ] [
- 1 hand-click# set
- ] if
- hand-last-button set
- millis hand-last-time set
- ] bind ;
-
-: update-clicked ( -- )
- hand-gadget get-global hand-clicked set-global
- hand-loc get-global hand-click-loc set-global ;
-
-: under-hand ( -- seq )
- hand-gadget get-global parents <reversed> ;
-
-: move-hand ( loc world -- )
- dup hand-world set-global
- under-hand >r over hand-loc set-global
- pick-up hand-gadget set-global
- under-hand r> hand-gestures ;
-
-: send-button-down ( gesture loc world -- )
- move-hand
- start-drag-timer
- dup button-down-#
- dup update-click# hand-buttons get-global push
- update-clicked
- button-gesture ;
-
-: send-button-up ( gesture loc world -- )
- move-hand
- dup button-up-# hand-buttons get-global delete
- stop-drag-timer
- button-gesture ;
-
-: send-wheel ( direction loc world -- )
- move-hand
- scroll-direction set-global
- T{ mouse-scroll } hand-gadget get-global send-gesture
- drop ;
-
-: world-focus ( world -- gadget )
- dup gadget-focus [ world-focus ] [ ] ?if ;
-
-: send-action ( world gesture -- )
- swap world-focus send-gesture drop ;
-
-: resend-button-down ( gesture world -- )
- hand-loc get-global swap send-button-down ;
-
-: resend-button-up ( gesture world -- )
- hand-loc get-global swap send-button-up ;
-
-GENERIC: gesture>string ( gesture -- string/f )
-
-: modifiers>string ( modifiers -- string )
- [ name>> ] map concat >string ;
-
-M: key-down gesture>string
- dup key-down-mods modifiers>string
- swap key-down-sym append ;
-
-M: button-up gesture>string
- [
- dup button-up-mods modifiers>string %
- "Click Button" %
- button-up-# [ " " % # ] when*
- ] "" make ;
-
-M: button-down gesture>string
- [
- dup button-down-mods modifiers>string %
- "Press Button" %
- button-down-# [ " " % # ] when*
- ] "" make ;
-
-M: left-action gesture>string drop "Swipe left" ;
-
-M: right-action gesture>string drop "Swipe right" ;
-
-M: up-action gesture>string drop "Swipe up" ;
-
-M: down-action gesture>string drop "Swipe down" ;
-
-M: zoom-in-action gesture>string drop "Zoom in" ;
-
-M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
-
-M: object gesture>string drop f ;
+++ /dev/null
-Translating window system events to gestures, and delivering gestures to gadgets
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.commands help.markup help.syntax ui.gadgets words
-kernel hashtables strings classes quotations sequences
-ui.gestures ;
-IN: ui.operations
-
-: $operations ( element -- )
- >quotation call
- f f operations>commands
- command-map. ;
-
-: $operation ( element -- )
- first +keyboard+ word-prop gesture>string $snippet ;
-
-HELP: +keyboard+
-{ $description "A key which may be set in the hashtable passed to " { $link define-operation } ". The value is a gesture." } ;
-
-HELP: +primary+
-{ $description "A key which may be set in the hashtable passed to " { $link define-operation } ". If set to a true value, this operation becomes the default operation performed when a presentation matching the operation's predicate is clicked with the mouse." } ;
-
-HELP: operation
-{ $description "An abstraction for an operation which may be performed on a presentation."
-$nl
-"Operations have the following slots:"
-{ $list
- { { $link operation-predicate } " - a quotation with stack effect " { $snippet "( obj -- ? )" } }
- { { $link operation-command } " - a " { $link word } }
- { { $link operation-translator } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
- { { $link operation-hook } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
- { { $link operation-listener? } " - a boolean" }
-} } ;
-
-HELP: operation-gesture
-{ $values { "operation" operation } { "gesture" "a gesture or " { $link f } } }
-{ $description "Outputs the keyboard gesture associated with the operation." } ;
-
-HELP: operations
-{ $var-description "Global variable holding a vector of " { $link operation } " instances. New operations can be added with " { $link define-operation } "." } ;
-
-HELP: object-operations
-{ $values { "obj" object } { "operations" "a sequence of " { $link operation } " instances" } }
-{ $description "Outputs a sequence of operations applicable to the given object, by testing each defined operation's " { $link operation-predicate } " quotation in turn." } ;
-
-HELP: primary-operation
-{ $values { "obj" object } { "operation" "an " { $link operation } " or " { $link f } } }
-{ $description "Outputs the operation which should be invoked when a presentation of " { $snippet "obj" } " is clicked." } ;
-
-HELP: secondary-operation
-{ $values { "obj" object } { "operation" "an " { $link operation } " or " { $link f } } }
-{ $description "Outputs the operation which should be invoked when a " { $snippet "RET" } " is pressed while a presentation of " { $snippet "obj" } " is selected in a list." } ;
-
-HELP: define-operation
-{ $values { "pred" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "command" word } { "flags" hashtable } }
-{ $description "Defines an operation on objects matching the predicate. The hashtable can contain the following keys:"
- { $list
- { { $link +listener+ } " - if set to a true value, the operation will run in the listener" }
- { { $link +description+ } " - can be set to a string description of the operation" }
- { { $link +primary+ } " - if set to a true value, the operation will be output by " { $link primary-operation } " when applied to an object satisfying the predicate" }
- { { $link +secondary+ } " - if set to a true value, the operation will be output by " { $link secondary-operation } " when applied to an object satisfying the predicate" }
- { { $link +keyboard+ } " - can be set to a keyboard gesture; the guesture will be used by " { $link define-operation-map } }
- }
-} ;
-
-HELP: define-operation-map
-{ $values { "class" "a class word" } { "group" string } { "blurb" "a " { $link string } " or " { $link f } } { "object" object } { "hook" "a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } { "translator" "a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } }
-{ $description "Defines a command map named " { $snippet "group" } " on " { $snippet "class" } " consisting of operations applicable to " { $snippet "object" } ". The hook quotation is applied to the target gadget; the translator quotation is applied to the result of the hook. Finally the result of the translator is passed to the operation. A distinction is drawn between the hook and the translator because for listener operations, the hook runs in the event loop and the translator runs in the listener. This avoids polluting the listener output with large prettyprinted gadgets and long quotations." } ;
-
-HELP: $operations
-{ $values { "element" "a sequence" } }
-{ $description "Converts the element to a quotation and calls it; the resulting quotation must have stack effect " { $snippet "( -- obj )" } ". Prints a list of operations applicable to the object, together with keyboard shortcuts." } ;
-
-HELP: $operation
-{ $values { "element" "a sequence containing a single word" } }
-{ $description "Prints the keyboard shortcut associated with the word, which must have been previously defined as an operation by a call to " { $link define-operation } "." } ;
-
-ARTICLE: "ui-operations" "Operations"
-"Operations are commands performed on presentations."
-{ $subsection operation }
-{ $subsection define-operation }
-{ $subsection primary-operation }
-{ $subsection secondary-operation }
-{ $subsection define-operation-map }
-"When documenting gadgets, operation documentation can be automatically generated:"
-{ $subsection $operations }
-{ $subsection $operation } ;
-
-ABOUT: "ui-operations"
+++ /dev/null
-IN: ui.operations.tests
-USING: ui.operations ui.commands prettyprint kernel namespaces
-tools.test ui.gadgets ui.gadgets.editors parser io
-io.streams.string math help help.markup ;
-
-: my-pprint pprint ;
-
-[ drop t ] \ my-pprint [ ] [ ] f operation boa "op" set
-
-[ [ 3 my-pprint ] ] [
- 3 "op" get operation-command command-quot
-] unit-test
-
-[ "3" ] [ [ 3 "op" get invoke-command ] with-string-writer ] unit-test
-
-[ drop t ] \ my-pprint [ ] [ editor-string ] f operation boa
-"op" set
-
-[ "\"4\"" ] [
- [
- "4" <editor> [ set-editor-string ] keep
- "op" get invoke-command
- ] with-string-writer
-] unit-test
-
-[ ] [
- [ { $operations \ + } print-element ] with-string-writer drop
-] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays definitions kernel ui.commands
-ui.gestures sequences strings math words generic namespaces
-hashtables help.markup quotations assocs ;
-IN: ui.operations
-
-SYMBOL: +keyboard+
-SYMBOL: +primary+
-SYMBOL: +secondary+
-
-TUPLE: operation predicate command translator hook listener? ;
-
-: <operation> ( predicate command -- operation )
- operation new
- [ ] >>hook
- [ ] >>translator
- swap >>command
- swap >>predicate ;
-
-PREDICATE: listener-operation < operation
- dup operation-command listener-command?
- swap operation-listener? or ;
-
-M: operation command-name
- operation-command command-name ;
-
-M: operation command-description
- operation-command command-description ;
-
-M: operation command-word operation-command command-word ;
-
-: operation-gesture ( operation -- gesture )
- operation-command +keyboard+ word-prop ;
-
-SYMBOL: operations
-
-: object-operations ( obj -- operations )
- operations get [ operation-predicate call ] with filter ;
-
-: find-operation ( obj quot -- command )
- >r object-operations r> find-last nip ; inline
-
-: primary-operation ( obj -- operation )
- [ operation-command +primary+ word-prop ] find-operation ;
-
-: secondary-operation ( obj -- operation )
- dup
- [ operation-command +secondary+ word-prop ] find-operation
- [ ] [ primary-operation ] ?if ;
-
-: default-flags ( -- assoc )
- H{ { +keyboard+ f } { +primary+ f } { +secondary+ f } } ;
-
-: define-operation ( pred command flags -- )
- default-flags swap assoc-union
- dupd define-command <operation>
- operations get push ;
-
-: modify-operation ( hook translator operation -- operation )
- clone
- tuck set-operation-translator
- tuck set-operation-hook
- t over set-operation-listener? ;
-
-: modify-operations ( operations hook translator -- operations )
- rot [ >r 2dup r> modify-operation ] map 2nip ;
-
-: operations>commands ( object hook translator -- pairs )
- >r >r object-operations r> r> modify-operations
- [ [ operation-gesture ] keep ] { } map>assoc ;
-
-: define-operation-map ( class group blurb object hook translator -- )
- operations>commands define-command-map ;
-
-: operation-quot ( target command -- quot )
- [
- swap literalize ,
- dup operation-translator %
- operation-command ,
- ] [ ] make ;
-
-M: operation invoke-command ( target command -- )
- [ operation-hook call ] keep operation-quot call ;
+++ /dev/null
-Operations are commands which may be performed on a presentation's underlying object
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets ui.gestures help.markup help.syntax
-kernel classes strings opengl.gl models math.geometry.rect ;
-IN: ui.render
-
-HELP: gadget
-{ $class-description "An object which displays itself on the screen and acts on user input gestures. Gadgets have the following slots:"
- { $list
- { { $snippet "pref-dim" } " - a cached value for " { $link pref-dim } "; do not read or write this slot directly." }
- { { $snippet "parent" } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
- { { $snippet "children" } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
- { { $snippet "orientation" } " - an orientation specifier. This slot is used by layout gadgets." }
- { { $snippet "layout-state" } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
- { { $snippet "visible?" } " - a boolean indicating if the gadget should display and receive user input." }
- { { $snippet "root?" } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
- { { $snippet "clipped?" } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
- { { $snippet "interior" } " - an object whose class implements the " { $link draw-interior } " generic word." }
- { { $snippet "boundary" } " - an object whose class implements the " { $link draw-boundary } " generic word." }
- { { $snippet "model" } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
- }
-"Gadgets subclass the " { $link rect } " class, and thus all instances have " { $snippet "loc" } " and " { $snippet "dim" } " instances holding their location and dimensions." }
-{ $notes
-"Other classes may inherit from " { $link gadget } " in order to re-implement generic words such as " { $link draw-gadget* } " and " { $link user-input* } ", or to define gestures with " { $link set-gestures } "." } ;
-
-HELP: clip
-{ $var-description "The current clipping rectangle." } ;
-
-HELP: draw-gadget*
-{ $values { "gadget" gadget } }
-{ $contract "Draws the gadget by making OpenGL calls. The top-left corner of the gadget should be drawn at the location stored in the " { $link origin } " variable." }
-{ $notes "This word should not be called directly. To force a gadget to redraw, call " { $link relayout-1 } "." } ;
-
-HELP: draw-interior
-{ $values { "interior" object } { "gadget" gadget } }
-{ $contract "Draws the interior of a gadget by making OpenGL calls. The " { $link gadget-interior } " slot may be set to objects implementing this generic word." } ;
-
-HELP: draw-boundary
-{ $values { "boundary" object } { "gadget" gadget } }
-{ $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $link gadget-boundary } " slot may be set to objects implementing this generic word." } ;
-
-HELP: solid
-{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid fill, respectively. The " { $link solid-color } " slot stores a color specifier." } ;
-
-HELP: gradient
-{ $class-description "A class implementing the " { $link draw-interior } " generic word to draw a smoothly shaded transition between colors. The " { $link gradient-colors } " slot stores a sequence of color specifiers and the gradient is drawn in the direction given by the " { $link gadget-orientation } " slot of the gadget." } ;
-
-HELP: polygon
-{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid filled polygon, respectively. Instances of " { $link polygon } " have two slots:"
- { $list
- { { $link polygon-color } " - a color specifier" }
- { { $link polygon-points } " - a sequence of points" }
- }
-} ;
-
-HELP: <polygon>
-{ $values { "color" "a color specifier" } { "points" "a sequence of points" } }
-{ $description "Creates a new instance of " { $link polygon } "." } ;
-
-HELP: <polygon-gadget>
-{ $values { "color" "a color specifier" } { "points" "a sequence of points" } { "gadget" "a new " { $link gadget } } }
-{ $description "Creates a gadget which is drawn as a solid filled polygon. The gadget's size is the minimum bounding box containing all the points of the polygon." } ;
-
-HELP: open-font
-{ $values { "font" "a font specifier" } { "open-font" object } }
-{ $description "Loads a font if it has not already been loaded, otherwise outputs the existing font." }
-{ $errors "Throws an error if the font does not exist." } ;
-
-HELP: string-width
-{ $values { "open-font" "a value output by " { $link open-font } } { "string" string } { "w" "a positive integer" } }
-{ $description "Outputs the width of a string." } ;
-
-HELP: text-dim
-{ $values { "open-font" "a value output by " { $link open-font } } { "text" "a string or an array of strings" } { "dim" "a pair of integers" } }
-{ $description "Outputs the dimensions of a piece of text, which is either a single-line string or an array of lines." } ;
-
-HELP: draw-string
-{ $values { "font" "a font specifier" } { "string" string } { "loc" "a pair of integers" } }
-{ $description "Draws a line of text." } ;
-
-HELP: draw-text
-{ $values { "font" "a font specifier" } { "text" "a string or an array of strings" } { "loc" "a pair of integers" } }
-{ $description "Draws text. Text is either a single-line string or an array of lines." } ;
-
-ARTICLE: "gadgets-polygons" "Polygon gadgets"
-"A polygon gadget renders a simple shaded polygon."
-{ $subsection <polygon-gadget> }
-"Some pre-made polygons:"
-{ $subsection arrow-up }
-{ $subsection arrow-right }
-{ $subsection arrow-down }
-{ $subsection arrow-left }
-{ $subsection close-box }
-"Polygon gadgets are rendered by the " { $link polygon } " pen protocol implementation." ;
-
-ARTICLE: "ui-paint" "Customizing gadget appearance"
-"The UI carries out the following steps when drawing a gadget:"
-{ $list
- { "The " { $link draw-interior } " generic word is called on the value of the " { $link gadget-interior } " slot." }
- { "The " { $link draw-gadget* } " generic word is called on the gadget." }
- { "The gadget's visible children are drawn, determined by calling " { $link visible-children } " on the gadget." }
- { "The " { $link draw-boundary } " generic word is called on the value of the " { $link gadget-boundary } " slot." }
-}
-"Now, each one of these steps will be covered in detail."
-{ $subsection "ui-pen-protocol" }
-{ $subsection "ui-paint-custom" } ;
-
-ARTICLE: "ui-pen-protocol" "UI pen protocol"
-"The " { $link gadget-interior } " and " { $link gadget-boundary } " slots of a gadget facilitate easy factoring and sharing of drawing logic. Objects stored in these slots must implement the pen protocol:"
-{ $subsection draw-interior }
-{ $subsection draw-boundary }
-"The default value of these slots is the " { $link f } " singleton, which implements the above protocol by doing nothing."
-$nl
-"Some other pre-defined implementations:"
-{ $subsection solid }
-{ $subsection gradient }
-{ $subsection polygon }
-"Custom implementations must follow the guidelines set forth in " { $link "ui-paint-custom" } "." ;
-
-ARTICLE: "text-rendering" "Rendering text"
-"Unlike OpenGL, Factor's FreeType binding only includes the bare essentials, and there is rarely any need to directly call words in the " { $vocab-link "freetype" } " vocabulary directly. Instead, the UI provides high-level wrappers."
-$nl
-"Font objects are never constructed directly, and instead are obtained by calling a word:"
-{ $subsection open-font }
-"Measuring text:"
-{ $subsection text-dim }
-{ $subsection text-height }
-{ $subsection text-width }
-"Rendering text:"
-{ $subsection draw-string }
-{ $subsection draw-text } ;
-
-ARTICLE: "ui-paint-custom" "Implementing custom drawing logic"
-"The UI uses OpenGL to render gadgets. Custom rendering logic can be plugged in with the " { $link "ui-pen-protocol" } ", or by implementing a generic word:"
-{ $subsection draw-gadget* }
-"Custom drawing code has access to the full OpenGL API in the " { $vocab-link "opengl" } " vocabulary."
-$nl
-"The UI uses a co-ordinate system where the y axis is oriented down. The OpenGL " { $link GL_MODELVIEW } " matrix is not saved or restored when rendering a gadget. Instead, the origin of the gadget relative to the OpenGL context is stored in a variable:"
-{ $subsection origin }
-"Custom drawing implementations can translate co-ordinates manually, or save and restore the " { $link GL_MODELVIEW } " matrix."
-$nl
-"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa."
-$nl
-"Gadgets must not draw outside of their bounding box, however clipping is not enforced by default, for performance reasons. This can be changed by setting the " { $link gadget-clipped? } " slot to " { $link t } " in the gadget's constructor."
-$nl
-"Saving the " { $link GL_MODELVIEW } " matrix and enabling/disabling flags can be done in a clean way using the combinators documented in the following section."
-{ $subsection "gl-utilities" }
-{ $subsection "text-rendering" } ;
-
-ABOUT: "ui-paint-custom"
+++ /dev/null
-! Copyright (C) 2005, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays hashtables io kernel math namespaces opengl
-opengl.gl opengl.glu sequences strings io.styles vectors
-combinators math.vectors ui.gadgets colors
-math.order math.geometry.rect ;
-IN: ui.render
-
-SYMBOL: clip
-
-SYMBOL: viewport-translation
-
-: flip-rect ( rect -- loc dim )
- rect-bounds [
- >r { 1 -1 } v* r> { 0 -1 } v* v+
- viewport-translation get v+
- ] keep ;
-
-: do-clip ( -- ) clip get flip-rect gl-set-clip ;
-
-: init-clip ( clip-rect rect -- )
- GL_SCISSOR_TEST glEnable
- [ rect-intersect ] keep
- rect-dim dup { 0 1 } v* viewport-translation set
- { 0 0 } over gl-viewport
- 0 swap first2 0 gluOrtho2D
- clip set
- do-clip ;
-
-: init-gl ( clip-rect rect -- )
- GL_SMOOTH glShadeModel
- GL_BLEND glEnable
- GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
- init-matrices
- init-clip
- ! white gl-clear is broken w.r.t window resizing
- ! Linux/PPC Radeon 9200
- white set-color
- clip get rect-extent gl-fill-rect ;
-
-GENERIC: draw-gadget* ( gadget -- )
-
-M: gadget draw-gadget* drop ;
-
-GENERIC: draw-interior ( gadget interior -- )
-
-GENERIC: draw-boundary ( gadget boundary -- )
-
-SYMBOL: origin
-
-{ 0 0 } origin set-global
-
-: visible-children ( gadget -- seq )
- clip get origin get vneg offset-rect swap children-on ;
-
-: translate ( rect/point -- ) rect-loc origin [ v+ ] change ;
-
-DEFER: draw-gadget
-
-: (draw-gadget) ( gadget -- )
- [
- dup translate
- dup dup gadget-interior draw-interior
- dup draw-gadget*
- dup visible-children [ draw-gadget ] each
- dup gadget-boundary draw-boundary
- ] with-scope ;
-
-: >absolute ( rect -- rect )
- origin get offset-rect ;
-
-: change-clip ( gadget -- )
- >absolute clip [ rect-intersect ] change ;
-
-: with-clipping ( gadget quot -- )
- clip get >r
- over change-clip do-clip call
- r> clip set do-clip ; inline
-
-: draw-gadget ( gadget -- )
- {
- { [ dup gadget-visible? not ] [ drop ] }
- { [ dup gadget-clipped? not ] [ (draw-gadget) ] }
- [ [ (draw-gadget) ] with-clipping ]
- } cond ;
-
-! Pen paint properties
-M: f draw-interior 2drop ;
-M: f draw-boundary 2drop ;
-
-! Solid fill/border
-TUPLE: solid color ;
-
-C: <solid> solid
-
-! Solid pen
-: (solid) ( gadget paint -- loc dim )
- solid-color set-color rect-dim >r origin get dup r> v+ ;
-
-M: solid draw-interior (solid) gl-fill-rect ;
-
-M: solid draw-boundary (solid) gl-rect ;
-
-! Gradient pen
-TUPLE: gradient colors ;
-
-C: <gradient> gradient
-
-M: gradient draw-interior
- origin get [
- over gadget-orientation
- swap gradient-colors
- rot rect-dim
- gl-gradient
- ] with-translation ;
-
-! Polygon pen
-TUPLE: polygon color points ;
-
-C: <polygon> polygon
-
-: draw-polygon ( polygon quot -- )
- origin get [
- >r dup polygon-color set-color polygon-points r> call
- ] with-translation ; inline
-
-M: polygon draw-boundary
- [ gl-poly ] draw-polygon drop ;
-
-M: polygon draw-interior
- [ gl-fill-poly ] draw-polygon drop ;
-
-: arrow-up { { 3 0 } { 6 6 } { 0 6 } } ;
-: arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;
-: arrow-down { { 0 0 } { 6 0 } { 3 6 } } ;
-: arrow-left { { 0 3 } { 6 0 } { 6 6 } } ;
-: close-box { { 0 0 } { 6 0 } { 6 6 } { 0 6 } } ;
-
-: <polygon-gadget> ( color points -- gadget )
- dup max-dim
- >r <polygon> <gadget> r> over set-rect-dim
- [ set-gadget-interior ] keep ;
-
-! Font rendering
-SYMBOL: font-renderer
-
-HOOK: open-font font-renderer ( font -- open-font )
-
-HOOK: string-width font-renderer ( open-font string -- w )
-
-HOOK: string-height font-renderer ( open-font string -- h )
-
-HOOK: draw-string font-renderer ( font string loc -- )
-
-HOOK: x>offset font-renderer ( x open-font string -- n )
-
-HOOK: free-fonts font-renderer ( world -- )
-
-: text-height ( open-font text -- n )
- dup string? [
- string-height
- ] [
- [ string-height ] with map sum
- ] if ;
-
-: text-width ( open-font text -- n )
- dup string? [
- string-width
- ] [
- 0 -rot [ string-width max ] with each
- ] if ;
-
-: text-dim ( open-font text -- dim )
- [ text-width ] 2keep text-height 2array ;
-
-: draw-text ( font text loc -- )
- over string? [
- draw-string
- ] [
- [
- [
- 2dup { 0 0 } draw-string
- >r open-font r> string-height
- 0.0 swap 0.0 glTranslated
- ] with each
- ] with-translation
- ] if ;
+++ /dev/null
-Support for rendering gadgets via OpenGL
+++ /dev/null
-Factor's graphical user interface framework
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Slava Pestov
+++ /dev/null
-IN: ui.tools.browser.tests
-USING: tools.test tools.test.ui ui.tools.browser ;
-
-\ <browser-gadget> must-infer
-[ ] [ <browser-gadget> [ ] with-grafted-gadget ] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: debugger ui.tools.workspace help help.topics kernel
-models models.history ui.commands ui.gadgets ui.gadgets.panes
-ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
-ui.gadgets.buttons compiler.units assocs words vocabs
-accessors ;
-IN: ui.tools.browser
-
-TUPLE: browser-gadget < track pane history ;
-
-: show-help ( link help -- )
- dup history>> add-history
- >r >link r> history>> set-model ;
-
-: <help-pane> ( browser-gadget -- gadget )
- history>> [ [ help ] curry try ] <pane-control> ;
-
-: init-history ( browser-gadget -- )
- "handbook" >link <history> >>history drop ;
-
-: <browser-gadget> ( -- gadget )
- { 0 1 } browser-gadget new-track
- dup init-history
- dup <toolbar> f track-add
- dup <help-pane> >>pane
- dup pane>> <scroller> 1 track-add ;
-
-M: browser-gadget call-tool* show-help ;
-
-M: browser-gadget tool-scroller
- pane>> find-scroller ;
-
-M: browser-gadget graft*
- [ add-definition-observer ] [ call-next-method ] bi ;
-
-M: browser-gadget ungraft*
- [ call-next-method ] [ remove-definition-observer ] bi ;
-
-: showing-definition? ( defspec assoc -- ? )
- [ key? ] 2keep
- [ >r dup word-link? [ link-name ] when r> key? ] 2keep
- >r dup vocab-link? [ vocab ] when r> key?
- or or ;
-
-M: browser-gadget definitions-changed ( assoc browser -- )
- history>>
- dup model-value rot showing-definition?
- [ notify-connections ] [ drop ] if ;
-
-: help-action ( browser-gadget -- link )
- history>> model-value >link ;
-
-: com-follow ( link -- ) browser-gadget call-tool ;
-
-: com-back ( browser -- ) history>> go-back ;
-
-: com-forward ( browser -- ) history>> go-forward ;
-
-: com-documentation ( browser -- ) "handbook" swap show-help ;
-
-: com-vocabularies ( browser -- ) "vocab-index" swap show-help ;
-
-: browser-help ( -- ) "ui-browser" help-window ;
-
-\ browser-help H{ { +nullary+ t } } define-command
-
-browser-gadget "toolbar" f {
- { T{ key-down f { A+ } "b" } com-back }
- { T{ key-down f { A+ } "f" } com-forward }
- { T{ key-down f { A+ } "h" } com-documentation }
- { T{ key-down f { A+ } "v" } com-vocabularies }
- { T{ key-down f f "F1" } browser-help }
-} define-command-map
-
-browser-gadget "multi-touch" f {
- { T{ left-action } com-back }
- { T{ right-action } com-forward }
-} define-command-map
+++ /dev/null
-Graphical help browser
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets help.markup help.syntax kernel quotations
-continuations debugger ui ;
-IN: ui.tools.debugger
-
-HELP: <debugger>
-{ $values { "error" "an error" } { "restarts" "a sequence of " { $link restart } " instances" } { "restart-hook" "a quotation with stack effect " { $snippet "( list -- )" } } { "gadget" "a new " { $link gadget } } }
-{ $description
- "Creates a gadget displaying a description of the error, along with buttons to print the contents of the stacks in the listener, and a list of restarts."
-} ;
-
-{ <debugger> debugger-window ui-try } related-words
-
-HELP: debugger-window
-{ $values { "error" "an error" } }
-{ $description "Opens a window with a description of the error." } ;
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays ui ui.commands ui.gestures ui.gadgets
- ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
- ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
- ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
- ui.gadgets.scrollers ui.gadgets.panes hashtables io kernel math
- models namespaces sequences sequences words continuations
- debugger prettyprint ui.tools.traceback help editors ;
-
-IN: ui.tools.debugger
-
-: <restart-list> ( restarts restart-hook -- gadget )
- [ restart-name ] rot <model> <list> ;
-
-TUPLE: debugger < track restarts ;
-
-: <debugger-display> ( restart-list error -- gadget )
- <filled-pile>
- <pane>
- swapd tuck [ print-error ] with-pane
- add-gadget
-
- swap add-gadget ;
-
-: <debugger> ( error restarts restart-hook -- gadget )
- { 0 1 } debugger new-track
- dup <toolbar> f track-add
- -rot <restart-list> >>restarts
- dup restarts>> rot <debugger-display> <scroller> 1 track-add ;
-
-M: debugger focusable-child* debugger-restarts ;
-
-: debugger-window ( error -- )
- #! No restarts for the debugger window
- f [ drop ] <debugger> "Error" open-window ;
-
-[ debugger-window ] ui-error-hook set-global
-
-M: world-error error.
- "An error occurred while drawing the world " write
- dup world>> pprint-short "." print
- "This world has been deactivated to prevent cascading errors." print
- error>> error. ;
-
-debugger "gestures" f {
- { T{ button-down } request-focus }
-} define-command-map
-
-: com-traceback ( -- ) error-continuation get traceback-window ;
-
-\ com-traceback H{ { +nullary+ t } } define-command
-
-\ :help H{ { +nullary+ t } { +listener+ t } } define-command
-
-\ :edit H{ { +nullary+ t } { +listener+ t } } define-command
-
-debugger "toolbar" f {
- { T{ key-down f f "s" } com-traceback }
- { T{ key-down f f "h" } :help }
- { T{ key-down f f "e" } :edit }
-} define-command-map
+++ /dev/null
-Graphical error display
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax ;
-IN: ui.tools.deploy
-
-HELP: deploy-tool
-{ $values { "vocab" "a vocabulary specifier" } }
-{ $description "Opens the graphical deployment tool for the specified vocabulary." }
-{ $examples { $code "\"tetris\" deploy-tool" } } ;
-
-ARTICLE: "ui.tools.deploy" "Application deployment UI tool"
-"The application deployment UI tool provides a graphical front-end to deployment configuration. Using the tool, you can set deployment options graphically."
-$nl
-"To start the tool, pass a vocabulary name to a word:"
-{ $subsection deploy-tool }
-"Alternatively, right-click on a vocabulary presentation in the UI and choose " { $strong "Deploy tool" } " from the resulting popup menu."
-{ $see-also "tools.deploy" } ;
-
-ABOUT: "ui.tools.deploy"
+++ /dev/null
-! Copyright (C) 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: ui.gadgets colors kernel ui.render namespaces
- models models.mapping sequences ui.gadgets.buttons
- ui.gadgets.packs ui.gadgets.labels tools.deploy.config
- namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
- ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
- tools.deploy vocabs ui.tools.workspace system accessors ;
-
-IN: ui.tools.deploy
-
-TUPLE: deploy-gadget < pack vocab settings ;
-
-: bundle-name ( parent -- parent )
- deploy-name get <field>
- "Executable name:" label-on-left add-gadget ;
-
-: deploy-ui ( parent -- parent )
- deploy-ui? get
- "Include user interface framework" <checkbox> add-gadget ;
-
-: exit-when-windows-closed ( parent -- parent )
- "stop-after-last-window?" get
- "Exit when last UI window closed" <checkbox> add-gadget ;
-
-: io-settings ( parent -- parent )
- "Input/output support:" <label> add-gadget
- deploy-io get deploy-io-options <radio-buttons> add-gadget ;
-
-: reflection-settings ( parent -- parent )
- "Reflection support:" <label> add-gadget
- deploy-reflection get deploy-reflection-options <radio-buttons> add-gadget ;
-
-: advanced-settings ( parent -- parent )
- "Advanced:" <label> add-gadget
- deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
- deploy-math? get "Rational and complex number support" <checkbox> add-gadget
- deploy-threads? get "Threading support" <checkbox> add-gadget
- deploy-random? get "Random number generator support" <checkbox> add-gadget
- deploy-word-props? get "Retain all word properties" <checkbox> add-gadget
- deploy-word-defs? get "Retain all word definitions" <checkbox> add-gadget
- deploy-c-types? get "Retain all C types" <checkbox> add-gadget ;
-
-: deploy-settings-theme ( gadget -- gadget )
- { 10 10 } >>gap
- 1 >>fill ;
-
-: <deploy-settings> ( vocab -- control )
- default-config [ <model> ] assoc-map
- [
- <pile>
- bundle-name
- deploy-ui
- os macosx? [ exit-when-windows-closed ] when
- io-settings
- reflection-settings
- advanced-settings
-
- deploy-settings-theme
- namespace <mapping> over set-gadget-model
- ]
- bind ;
-
-: find-deploy-gadget ( gadget -- deploy-gadget )
- [ deploy-gadget? ] find-parent ;
-
-: find-deploy-vocab ( gadget -- vocab )
- find-deploy-gadget deploy-gadget-vocab ;
-
-: find-deploy-config ( gadget -- config )
- find-deploy-vocab deploy-config ;
-
-: find-deploy-settings ( gadget -- settings )
- find-deploy-gadget deploy-gadget-settings ;
-
-: com-revert ( gadget -- )
- dup find-deploy-config
- swap find-deploy-settings set-control-value ;
-
-: com-save ( gadget -- )
- dup find-deploy-settings control-value
- swap find-deploy-vocab set-deploy-config ;
-
-: com-deploy ( gadget -- )
- dup com-save
- dup find-deploy-vocab [ deploy ] curry call-listener
- close-window ;
-
-: com-help ( -- )
- "ui.tools.deploy" help-window ;
-
-\ com-help H{
- { +nullary+ t }
-} define-command
-
-: com-close ( gadget -- )
- close-window ;
-
-deploy-gadget "toolbar" f {
- { f com-close }
- { f com-help }
- { f com-revert }
- { f com-save }
- { T{ key-down f f "RET" } com-deploy }
-} define-command-map
-
-: <deploy-gadget> ( vocab -- gadget )
- deploy-gadget new-gadget
- over >>vocab
- { 0 1 } >>orientation
- swap <deploy-settings> >>settings
- dup settings>> add-gadget
- dup <toolbar> { 10 10 } >>gap add-gadget
- deploy-settings-theme
- dup com-revert ;
-
-: deploy-tool ( vocab -- )
- vocab-name dup <deploy-gadget> 10 <border>
- "Deploying \"" rot "\"" 3append open-window ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ui.tools.workspace inspector kernel ui.commands
-ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
-ui.gadgets.slots ui.gadgets.tracks ui.gestures
-ui.gadgets.buttons namespaces ;
-IN: ui.tools.inspector
-
-TUPLE: inspector-gadget < track object pane ;
-
-: refresh ( inspector -- )
- [ object>> ] [ pane>> ] bi [
- +editable+ on
- +number-rows+ on
- describe
- ] with-pane ;
-
-: <inspector-gadget> ( -- gadget )
- { 0 1 } inspector-gadget new-track
- dup <toolbar> f track-add
- <pane> >>pane
- dup pane>> <scroller> 1 track-add ;
-
-: inspect-object ( obj mirror keys inspector -- )
- 2nip swap >>object refresh ;
-
-\ &push H{ { +nullary+ t } { +listener+ t } } define-command
-
-\ &back H{ { +nullary+ t } { +listener+ t } } define-command
-
-\ &globals H{ { +nullary+ t } { +listener+ t } } define-command
-
-: inspector-help ( -- ) "ui-inspector" help-window ;
-
-\ inspector-help H{ { +nullary+ t } } define-command
-
-inspector-gadget "toolbar" f {
- { T{ update-object } refresh }
- { f &push }
- { f &back }
- { f &globals }
- { T{ key-down f f "F1" } inspector-help }
-} define-command-map
-
-inspector-gadget "multi-touch" f {
- { T{ left-action } &back }
-} define-command-map
-
-M: inspector-gadget tool-scroller
- inspector-gadget-pane find-scroller ;
+++ /dev/null
-Graphical object viewer and editor
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets ui.gadgets.editors listener io help.syntax
-help.markup ;
-IN: ui.tools.interactor
-
-HELP: interactor
-{ $class-description "An interactor is an " { $link editor } " intended to be used as the input component of a " { $link "ui-listener" } "."
-$nl
-"Interactors are created by calling " { $link <interactor> } "."
-$nl
-"Interactors implement the " { $link stream-readln } ", " { $link stream-read } " and " { $link read-quot } " generic words." } ;
+++ /dev/null
-IN: ui.tools.interactor.tests
-USING: ui.tools.interactor ui.gadgets.panes namespaces
-ui.gadgets.editors concurrency.promises threads listener
-tools.test kernel calendar parser accessors calendar io ;
-
-\ <interactor> must-infer
-
-[
- [ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
-
- [ ] [ "interactor" get register-self ] unit-test
-
- [ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
-
- [ ] [ <promise> "promise" set ] unit-test
-
- [
- self "interactor" get (>>thread)
- "interactor" get stream-read-quot "promise" get fulfill
- ] "Interactor test" spawn drop
-
- ! This should not throw an exception
- [ ] [ "interactor" get evaluate-input ] unit-test
-
- [ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test
-
- [ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test
-
- [ ] [ "interactor" get evaluate-input ] unit-test
-
- [ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
-] with-interactive-vocabs
-
-! Hang
-[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
-
-[ ] [ [ "interactor" get stream-read-quot drop ] "A" spawn drop ] unit-test
-
-[ ] [ [ "interactor" get stream-read-quot drop ] "B" spawn drop ] unit-test
-
-[ ] [ 1000 sleep ] unit-test
-
-[ ] [ "interactor" get interactor-eof ] unit-test
-
-[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
-
-: text "Hello world.\nThis is a test." ;
-
-[ ] [ text "interactor" get set-editor-string ] unit-test
-
-[ ] [ <promise> "promise" set ] unit-test
-
-[ ] [
- [
- "interactor" get register-self
- "interactor" get contents "promise" get fulfill
- ] in-thread
-] unit-test
-
-[ ] [ 100 sleep ] unit-test
-
-[ ] [ "interactor" get evaluate-input ] unit-test
-
-[ ] [ 100 sleep ] unit-test
-
-[ ] [ "interactor" get interactor-eof ] unit-test
-
-[ t ] [ "promise" get 2 seconds ?promise-timeout text = ] unit-test
-
-[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
-
-[ ] [ text "interactor" get set-editor-string ] unit-test
-
-[ ] [ <promise> "promise" set ] unit-test
-
-[ ] [
- [
- "interactor" get register-self
- "interactor" get stream-read1 "promise" get fulfill
- ] in-thread
-] unit-test
-
-[ ] [ 100 sleep ] unit-test
-
-[ ] [ "interactor" get evaluate-input ] unit-test
-
-[ CHAR: H ] [ "promise" get 2 seconds ?promise-timeout ] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs combinators continuations documents
-hashtables io io.styles kernel math math.order math.vectors
-models models.delay namespaces parser lexer prettyprint
-quotations sequences strings threads listener classes.tuple
-ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar
-ui.gadgets.presentations ui.gadgets.worlds ui.gestures
-definitions calendar concurrency.flags concurrency.mailboxes
-ui.tools.workspace accessors sets destructors ;
-IN: ui.tools.interactor
-
-! If waiting is t, we're waiting for user input, and invoking
-! evaluate-input resumes the thread.
-TUPLE: interactor < source-editor
-output history flag mailbox thread waiting help ;
-
-: register-self ( interactor -- )
- <mailbox> >>mailbox
- self >>thread
- drop ;
-
-: interactor-continuation ( interactor -- continuation )
- thread>> continuation>> value>> ;
-
-: interactor-busy? ( interactor -- ? )
- #! We're busy if there's no thread to resume.
- [ waiting>> ]
- [ thread>> dup [ thread-registered? ] when ]
- bi and not ;
-
-: interactor-use ( interactor -- seq )
- dup interactor-busy? [ drop f ] [
- use swap
- interactor-continuation name>>
- assoc-stack
- ] if ;
-
-: <help-model> ( interactor -- model )
- editor-caret 1/3 seconds <delay> ;
-
-: <interactor> ( output -- gadget )
- interactor new-editor
- V{ } clone >>history
- <flag> >>flag
- dup <help-model> >>help
- swap >>output ;
-
-M: interactor graft*
- [ call-next-method ] [ dup help>> add-connection ] bi ;
-
-M: interactor ungraft*
- [ dup help>> remove-connection ] [ call-next-method ] bi ;
-
-: word-at-loc ( loc interactor -- word )
- over [
- [ gadget-model T{ one-word-elt } elt-string ] keep
- interactor-use assoc-stack
- ] [
- 2drop f
- ] if ;
-
-M: interactor model-changed
- 2dup help>> eq? [
- swap model-value over word-at-loc swap show-summary
- ] [
- call-next-method
- ] if ;
-
-: write-input ( string input -- )
- <input> presented associate
- [ H{ { font-style bold } } format ] with-nesting ;
-
-: interactor-input. ( string interactor -- )
- output>> [
- dup string? [ dup write-input nl ] [ short. ] if
- ] with-output-stream* ;
-
-: add-interactor-history ( str interactor -- )
- over empty? [ 2drop ] [ interactor-history adjoin ] if ;
-
-: interactor-continue ( obj interactor -- )
- mailbox>> mailbox-put ;
-
-: clear-input ( interactor -- ) gadget-model clear-doc ;
-
-: interactor-finish ( interactor -- )
- #! The spawn is a kludge to make it infer. Stupid.
- [ editor-string ] keep
- [ interactor-input. ] 2keep
- [ add-interactor-history ] keep
- [ clear-input ] curry "Clearing input" spawn drop ;
-
-: interactor-eof ( interactor -- )
- dup interactor-busy? [
- f over interactor-continue
- ] unless drop ;
-
-: evaluate-input ( interactor -- )
- dup interactor-busy? [
- dup control-value over interactor-continue
- ] unless drop ;
-
-: interactor-yield ( interactor -- obj )
- dup thread>> self eq? [
- {
- [ t >>waiting drop ]
- [ flag>> raise-flag ]
- [ mailbox>> mailbox-get ]
- [ f >>waiting drop ]
- } cleave
- ] [ drop f ] if ;
-
-: interactor-read ( interactor -- lines )
- [ interactor-yield ] [ interactor-finish ] bi ;
-
-M: interactor stream-readln
- interactor-read dup [ first ] when ;
-
-: interactor-call ( quot interactor -- )
- dup interactor-busy? [
- 2dup interactor-input.
- 2dup interactor-continue
- ] unless 2drop ;
-
-M: interactor stream-read
- swap dup zero? [
- 2drop ""
- ] [
- >r interactor-read dup [ "\n" join ] when r> short head
- ] if ;
-
-M: interactor stream-read-partial
- stream-read ;
-
-M: interactor stream-read1
- dup interactor-read {
- { [ dup not ] [ 2drop f ] }
- { [ dup empty? ] [ drop stream-read1 ] }
- { [ dup first empty? ] [ 2drop CHAR: \n ] }
- [ nip first first ]
- } cond ;
-
-M: interactor dispose drop ;
-
-: go-to-error ( interactor error -- )
- [ line>> 1- ] [ column>> ] bi 2array
- over set-caret
- mark>caret ;
-
-: handle-parse-error ( interactor error -- )
- dup lexer-error? [ 2dup go-to-error error>> ] when
- swap find-workspace debugger-popup ;
-
-: try-parse ( lines interactor -- quot/error/f )
- [
- drop parse-lines-interactive
- ] [
- 2nip
- dup lexer-error? [
- dup error>> unexpected-eof? [ drop f ] when
- ] when
- ] recover ;
-
-: handle-interactive ( lines interactor -- quot/f ? )
- tuck try-parse {
- { [ dup quotation? ] [ nip t ] }
- { [ dup not ] [ drop "\n" swap user-input f f ] }
- [ handle-parse-error f f ]
- } cond ;
-
-M: interactor stream-read-quot
- [ interactor-yield ] keep {
- { [ over not ] [ drop ] }
- { [ over callable? ] [ drop ] }
- [
- [ handle-interactive ] keep swap
- [ interactor-finish ] [ nip stream-read-quot ] if
- ]
- } cond ;
-
-M: interactor pref-dim*
- [ line-height 4 * 0 swap 2array ] [ call-next-method ] bi
- vmax ;
-
-interactor "interactor" f {
- { T{ key-down f f "RET" } evaluate-input }
- { T{ key-down f { C+ } "k" } clear-input }
-} define-command-map
+++ /dev/null
-Interactors are used to input Factor code
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: continuations documents ui.tools.interactor
-ui.tools.listener hashtables kernel namespaces parser sequences
-tools.test ui.commands ui.gadgets ui.gadgets.editors
-ui.gadgets.panes vocabs words tools.test.ui slots.private
-threads arrays generic threads accessors listener ;
-IN: ui.tools.listener.tests
-
-[ f ] [ "word" source-editor command-map commands>> empty? ] unit-test
-
-[ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test
-
-[ ] [ <listener-gadget> "listener" set ] unit-test
-
-"listener" get [
- [ "dup" ] [
- \ dup word-completion-string
- ] unit-test
-
- [ "equal?" ]
- [ \ array \ equal? method word-completion-string ] unit-test
-
- <pane> <interactor> "i" set
-
- [ t ] [ "i" get interactor? ] unit-test
-
- [ ] [ "SYMBOL:" "i" get set-editor-string ] unit-test
-
- [ ] [
- "i" get [ { "SYMBOL:" } parse-lines ] [ go-to-error ] recover
- ] unit-test
-
- [ t ] [
- "i" get gadget-model doc-end
- "i" get editor-caret* =
- ] unit-test
-
- ! Race condition discovered by SimonRC
- [ ] [
- [
- "listener" get input>>
- [ stream-read-quot drop ]
- [ stream-read-quot drop ] bi
- ] "OH, HAI" spawn drop
- ] unit-test
-
- [ ] [ "listener" get clear-output ] unit-test
-
- [ ] [ "listener" get restart-listener ] unit-test
-
- [ ] [ 1000 sleep ] unit-test
-
- [ ] [ "listener" get com-end ] unit-test
-] with-grafted-gadget
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: inspector ui.tools.interactor ui.tools.inspector
-ui.tools.workspace help.markup io io.styles
-kernel models namespaces parser quotations sequences ui.commands
-ui.gadgets ui.gadgets.editors ui.gadgets.labelled
-ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
-ui.gadgets.tracks ui.gestures ui.operations vocabs words
-prettyprint listener debugger threads boxes concurrency.flags
-math arrays generic accessors combinators assocs ;
-IN: ui.tools.listener
-
-TUPLE: listener-gadget < track input output stack ;
-
-: listener-output, ( listener -- listener )
- <scrolling-pane> >>output
- dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
-
-: listener-streams ( listener -- input output )
- [ input>> ] [ output>> <pane-stream> ] bi ;
-
-: <listener-input> ( listener -- gadget )
- output>> <pane-stream> <interactor> ;
-
-: listener-input, ( listener -- listener )
- dup <listener-input> >>input
- dup input>>
- { 0 100 } <limited-scroller>
- "Input" <labelled-gadget>
- f track-add ;
-
-: welcome. ( -- )
- "If this is your first time with Factor, please read the " print
- "handbook" ($link) "." print nl ;
-
-M: listener-gadget focusable-child*
- input>> ;
-
-M: listener-gadget call-tool* ( input listener -- )
- >r string>> r> input>> set-editor-string ;
-
-M: listener-gadget tool-scroller
- output>> find-scroller ;
-
-: wait-for-listener ( listener -- )
- #! Wait for the listener to start.
- input>> flag>> wait-for-flag ;
-
-: workspace-busy? ( workspace -- ? )
- listener>> input>> interactor-busy? ;
-
-: listener-input ( string -- )
- get-workspace listener>> input>> set-editor-string ;
-
-: (call-listener) ( quot listener -- )
- input>> interactor-call ;
-
-: call-listener ( quot -- )
- [ workspace-busy? not ] get-workspace* listener>>
- [ dup wait-for-listener (call-listener) ] 2curry
- "Listener call" spawn drop ;
-
-M: listener-command invoke-command ( target command -- )
- command-quot call-listener ;
-
-M: listener-operation invoke-command ( target command -- )
- [ operation-hook call ] keep operation-quot call-listener ;
-
-: eval-listener ( string -- )
- get-workspace
- listener>> input>> [ set-editor-string ] keep
- evaluate-input ;
-
-: listener-run-files ( seq -- )
- dup empty? [
- drop
- ] [
- [ [ run-file ] each ] curry call-listener
- ] if ;
-
-: com-end ( listener -- )
- input>> interactor-eof ;
-
-: clear-output ( listener -- )
- output>> pane-clear ;
-
-\ clear-output H{ { +listener+ t } } define-command
-
-: clear-stack ( listener -- )
- [ clear ] swap (call-listener) ;
-
-GENERIC: word-completion-string ( word -- string )
-
-M: word word-completion-string
- name>> ;
-
-M: method-body word-completion-string
- "method-generic" word-prop word-completion-string ;
-
-USE: generic.standard.engines.tuple
-
-M: engine-word word-completion-string
- "engine-generic" word-prop word-completion-string ;
-
-: use-if-necessary ( word seq -- )
- over vocabulary>> [
- 2dup assoc-stack pick = [ 2drop ] [
- >r vocabulary>> vocab-words r> push
- ] if
- ] [ 2drop ] if ;
-
-: insert-word ( word -- )
- get-workspace workspace-listener input>>
- [ >r word-completion-string r> user-input ]
- [ interactor-use use-if-necessary ]
- 2bi ;
-
-: quot-action ( interactor -- lines )
- dup control-value
- dup "\n" join pick add-interactor-history
- swap select-all ;
-
-TUPLE: stack-display < track ;
-
-: <stack-display> ( workspace -- gadget )
- listener>>
- { 0 1 } stack-display new-track
- over <toolbar> f track-add
- swap
- stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
- 1 track-add ;
-
-M: stack-display tool-scroller
- find-workspace workspace-listener tool-scroller ;
-
-: ui-listener-hook ( listener -- )
- >r datastack r> listener-gadget-stack set-model ;
-
-: ui-error-hook ( error listener -- )
- find-workspace debugger-popup ;
-
-: ui-inspector-hook ( obj listener -- )
- find-workspace inspector-gadget
- swap show-tool inspect-object ;
-
-: listener-thread ( listener -- )
- dup listener-streams [
- [ [ ui-listener-hook ] curry listener-hook set ]
- [ [ ui-error-hook ] curry error-hook set ]
- [ [ ui-inspector-hook ] curry inspector-hook set ] tri
- welcome.
- listener
- ] with-streams* ;
-
-: start-listener-thread ( listener -- )
- [
- [ input>> register-self ] [ listener-thread ] bi
- ] curry "Listener" spawn drop ;
-
-: restart-listener ( listener -- )
- #! Returns when listener is ready to receive input.
- {
- [ com-end ]
- [ clear-output ]
- [ input>> clear-input ]
- [ start-listener-thread ]
- [ wait-for-listener ]
- } cleave ;
-
-: init-listener ( listener -- )
- f <model> swap set-listener-gadget-stack ;
-
-: <listener-gadget> ( -- gadget )
- { 0 1 } listener-gadget new-track
- dup init-listener
- listener-output,
- listener-input, ;
-
-: listener-help ( -- ) "ui-listener" help-window ;
-
-\ listener-help H{ { +nullary+ t } } define-command
-
-listener-gadget "toolbar" f {
- { f restart-listener }
- { T{ key-down f f "CLEAR" } clear-output }
- { T{ key-down f { C+ } "CLEAR" } clear-stack }
- { T{ key-down f { C+ } "d" } com-end }
- { T{ key-down f f "F1" } listener-help }
-} define-command-map
-
-M: listener-gadget handle-gesture* ( gadget gesture delegate -- ? )
- 3dup drop swap find-workspace workspace-page handle-gesture
- [ default-gesture-handler ] [ 3drop f ] if ;
-
-M: listener-gadget graft*
- [ call-next-method ] [ restart-listener ] bi ;
-
-M: listener-gadget ungraft*
- [ com-end ] [ call-next-method ] bi ;
+++ /dev/null
-Graphical code evaluator
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2006, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: continuations definitions ui.tools.browser
-ui.tools.interactor ui.tools.listener ui.tools.profiler
-ui.tools.search ui.tools.traceback ui.tools.workspace generic
-help.topics inference summary inspector io.files io.styles kernel
-namespaces parser prettyprint quotations tools.annotations
-editors tools.profiler tools.test tools.time tools.walker
-ui.commands ui.gadgets.editors ui.gestures ui.operations
-ui.tools.deploy vocabs vocabs.loader words sequences
-tools.vocabs classes compiler.units accessors ;
-IN: ui.tools.operations
-
-V{ } clone operations set-global
-
-! Objects
-[ drop t ] \ inspect H{
- { +primary+ t }
- { +listener+ t }
-} define-operation
-
-: com-prettyprint ( obj -- ) . ;
-
-[ drop t ] \ com-prettyprint H{
- { +listener+ t }
-} define-operation
-
-: com-push ( obj -- obj ) ;
-
-[ drop t ] \ com-push H{
- { +listener+ t }
-} define-operation
-
-: com-unparse ( obj -- ) unparse listener-input ;
-
-[ drop t ] \ com-unparse H{ } define-operation
-
-! Input
-
-: com-input ( obj -- ) string>> listener-input ;
-
-[ input? ] \ com-input H{
- { +primary+ t }
- { +secondary+ t }
-} define-operation
-
-! Restart
-[ restart? ] \ restart H{
- { +primary+ t }
- { +secondary+ t }
- { +listener+ t }
-} define-operation
-
-! Continuation
-[ continuation? ] \ traceback-window H{
- { +primary+ t }
- { +secondary+ t }
-} define-operation
-
-! Pathnames
-: edit-file ( pathname -- ) edit ;
-
-[ pathname? ] \ edit-file H{
- { +keyboard+ T{ key-down f { C+ } "E" } }
- { +primary+ t }
- { +secondary+ t }
- { +listener+ t }
-} define-operation
-
-UNION: definition word method-spec link vocab vocab-link ;
-
-[ definition? ] \ edit H{
- { +keyboard+ T{ key-down f { C+ } "E" } }
- { +listener+ t }
-} define-operation
-
-: com-forget ( defspec -- )
- [ forget ] with-compilation-unit ;
-
-[ definition? ] \ com-forget H{ } define-operation
-
-! Words
-[ word? ] \ insert-word H{
- { +secondary+ t }
-} define-operation
-
-[ topic? ] \ com-follow H{
- { +keyboard+ T{ key-down f { C+ } "H" } }
- { +primary+ t }
-} define-operation
-
-: com-usage ( word -- )
- get-workspace swap show-word-usage ;
-
-[ word? ] \ com-usage H{
- { +keyboard+ T{ key-down f { C+ } "U" } }
-} define-operation
-
-[ word? ] \ fix H{
- { +keyboard+ T{ key-down f { C+ } "F" } }
- { +listener+ t }
-} define-operation
-
-[ word? ] \ watch H{ } define-operation
-
-[ word? ] \ breakpoint H{ } define-operation
-
-GENERIC: com-stack-effect ( obj -- )
-
-M: quotation com-stack-effect infer. ;
-
-M: word com-stack-effect def>> com-stack-effect ;
-
-[ word? ] \ com-stack-effect H{
- { +listener+ t }
-} define-operation
-
-! Vocabularies
-: com-vocab-words ( vocab -- )
- get-workspace swap show-vocab-words ;
-
-[ vocab? ] \ com-vocab-words H{
- { +secondary+ t }
- { +keyboard+ T{ key-down f { C+ } "B" } }
-} define-operation
-
-: com-enter-in ( vocab -- ) vocab-name set-in ;
-
-[ vocab? ] \ com-enter-in H{
- { +keyboard+ T{ key-down f { C+ } "I" } }
- { +listener+ t }
-} define-operation
-
-: com-use-vocab ( vocab -- ) vocab-name use+ ;
-
-[ vocab-spec? ] \ com-use-vocab H{
- { +secondary+ t }
- { +listener+ t }
-} define-operation
-
-[ vocab-spec? ] \ run H{
- { +keyboard+ T{ key-down f { C+ } "R" } }
- { +listener+ t }
-} define-operation
-
-[ vocab? ] \ test H{
- { +keyboard+ T{ key-down f { C+ } "T" } }
- { +listener+ t }
-} define-operation
-
-[ vocab-spec? ] \ deploy-tool H{ } define-operation
-
-! Quotations
-[ quotation? ] \ com-stack-effect H{
- { +keyboard+ T{ key-down f { C+ } "i" } }
- { +listener+ t }
-} define-operation
-
-[ quotation? ] \ walk H{
- { +keyboard+ T{ key-down f { C+ } "w" } }
- { +listener+ t }
-} define-operation
-
-[ quotation? ] \ time H{
- { +keyboard+ T{ key-down f { C+ } "t" } }
- { +listener+ t }
-} define-operation
-
-: com-show-profile ( workspace -- )
- profiler-gadget call-tool ;
-
-: com-profile ( quot -- ) profile f com-show-profile ;
-
-[ quotation? ] \ com-profile H{
- { +keyboard+ T{ key-down f { C+ } "r" } }
- { +listener+ t }
-} define-operation
-
-! Profiler presentations
-[ dup usage-profile? swap vocab-profile? or ]
-\ com-show-profile H{ { +primary+ t } } define-operation
-
-! Operations -> commands
-source-editor
-"word"
-"These commands operate on the Factor word named by the token at the caret position."
-\ selected-word
-[ selected-word ]
-[ dup search [ ] [ no-word ] ?if ]
-define-operation-map
-
-interactor
-"quotation"
-"These commands operate on the entire contents of the input area."
-[ ]
-[ quot-action ]
-[ [ parse-lines ] with-compilation-unit ]
-define-operation-map
+++ /dev/null
-Standard presentation operations
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: ui.tools.workspace kernel quotations tools.profiler
-ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
-ui.gadgets.tracks ui.gestures ui.gadgets.buttons accessors ;
-IN: ui.tools.profiler
-
-TUPLE: profiler-gadget < track pane ;
-
-: <profiler-gadget> ( -- gadget )
- { 0 1 } profiler-gadget new-track
- dup <toolbar> f track-add
- <pane> >>pane
- dup pane>> <scroller> 1 track-add ;
-
-: with-profiler-pane ( gadget quot -- )
- >r profiler-gadget-pane r> with-pane ;
-
-: com-full-profile ( gadget -- )
- [ profile. ] with-profiler-pane ;
-
-: com-vocabs-profile ( gadget -- )
- [ vocabs-profile. ] with-profiler-pane ;
-
-: com-method-profile ( gadget -- )
- [ method-profile. ] with-profiler-pane ;
-
-: profiler-help ( -- ) "ui-profiler" help-window ;
-
-\ profiler-help H{ { +nullary+ t } } define-command
-
-profiler-gadget "toolbar" f {
- { f com-full-profile }
- { f com-vocabs-profile }
- { f com-method-profile }
- { T{ key-down f f "F1" } profiler-help }
-} define-command-map
-
-GENERIC: profiler-presentation ( obj -- quot )
-
-M: usage-profile profiler-presentation
- usage-profile-word [ usage-profile. ] curry ;
-
-M: vocab-profile profiler-presentation
- vocab-profile-vocab [ vocab-profile. ] curry ;
-
-M: f profiler-presentation
- drop [ vocabs-profile. ] ;
-
-M: profiler-gadget call-tool* ( obj gadget -- )
- swap profiler-presentation with-profiler-pane ;
+++ /dev/null
-Graphical call profiler
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: assocs ui.tools.search help.topics io.files io.styles
-kernel namespaces sequences source-files threads
-tools.test ui.gadgets ui.gestures vocabs
-vocabs.loader words tools.test.ui debugger ;
-IN: ui.tools.search.tests
-
-[ f ] [
- "no such word with this name exists, certainly"
- f f <definition-search>
- T{ key-down f { C+ } "x" } swap search-gesture
-] unit-test
-
-: assert-non-empty ( obj -- ) empty? f assert= ;
-
-: update-live-search ( search -- seq )
- dup [
- 300 sleep
- live-search-list control-value
- ] with-grafted-gadget ;
-
-: test-live-search ( gadget quot -- ? )
- >r update-live-search dup assert-non-empty r> all? ;
-
-[ t ] [
- "swp" all-words f <definition-search>
- [ word? ] test-live-search
-] unit-test
-
-[ t ] [
- "" all-words t <definition-search>
- dup [
- { "set-word-prop" } over live-search-field set-control-value
- 300 sleep
- search-value \ set-word-prop eq?
- ] with-grafted-gadget
-] unit-test
-
-[ t ] [
- "quot" <help-search>
- [ link? ] test-live-search
-] unit-test
-
-[ t ] [
- "factor" source-files get keys <source-file-search>
- [ pathname? ] test-live-search
-] unit-test
-
-[ t ] [
- "kern" <vocab-search>
- [ vocab-spec? ] test-live-search
-] unit-test
-
-[ t ] [
- "a" { "a" "b" "aa" } <history-search>
- [ input? ] test-live-search
-] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs ui.tools.interactor ui.tools.listener
-ui.tools.workspace help help.topics io.files io.styles kernel
-models models.delay models.filter namespaces prettyprint
-quotations sequences sorting source-files definitions strings
-tools.completion tools.crossref classes.tuple ui.commands
-ui.gadgets ui.gadgets.editors ui.gadgets.lists
-ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations
-vocabs words vocabs.loader tools.vocabs unicode.case calendar ui
-;
-IN: ui.tools.search
-
-TUPLE: live-search < track field list ;
-
-: search-value ( live-search -- value )
- live-search-list list-value ;
-
-: search-gesture ( gesture live-search -- operation/f )
- search-value object-operations
- [ operation-gesture = ] with find nip ;
-
-M: live-search handle-gesture* ( gadget gesture delegate -- ? )
- drop over search-gesture dup [
- over find-workspace hide-popup
- >r search-value r> invoke-command f
- ] [
- 2drop t
- ] if ;
-
-: find-live-search ( gadget -- search )
- [ [ live-search? ] is? ] find-parent ;
-
-: find-search-list ( gadget -- list )
- find-live-search live-search-list ;
-
-TUPLE: search-field < editor ;
-
-: <search-field> ( -- gadget )
- search-field new-editor ;
-
-search-field H{
- { T{ key-down f f "UP" } [ find-search-list select-previous ] }
- { T{ key-down f f "DOWN" } [ find-search-list select-next ] }
- { T{ key-down f f "PAGE_UP" } [ find-search-list list-page-up ] }
- { T{ key-down f f "PAGE_DOWN" } [ find-search-list list-page-down ] }
- { T{ key-down f f "RET" } [ find-search-list invoke-value-action ] }
-} set-gestures
-
-: <search-model> ( live-search producer -- live-search filter )
- >r dup field>> model>> ! live-search model :: producer
- ui-running? [ 1/5 seconds <delay> ] when
- [ "\n" join ] r> append <filter> ;
-
-: <search-list> ( live-search seq limited? presenter -- live-search list )
- >r
- [ limited-completions ] [ completions ] ? curry
- <search-model>
- >r [ find-workspace hide-popup ] r> r>
- swap <list> ;
-
-: <live-search> ( string seq limited? presenter -- gadget )
- { 0 1 } live-search new-track
- <search-field> >>field
- dup field>> f track-add
- -roll <search-list> >>list
- dup list>> <scroller> 1 track-add
-
- swap
- over field>> set-editor-string
- dup field>> end-of-document ;
-
-M: live-search focusable-child* live-search-field ;
-
-M: live-search pref-dim* drop { 400 200 } ;
-
-: current-word ( workspace -- string )
- workspace-listener listener-gadget-input selected-word ;
-
-: definition-candidates ( words -- candidates )
- [ dup synopsis >lower ] { } map>assoc sort-values ;
-
-: <definition-search> ( string words limited? -- gadget )
- >r definition-candidates r> [ synopsis ] <live-search> ;
-
-: word-candidates ( words -- candidates )
- [ dup name>> >lower ] { } map>assoc ;
-
-: <word-search> ( string words limited? -- gadget )
- >r word-candidates r> [ synopsis ] <live-search> ;
-
-: com-words ( workspace -- )
- dup current-word all-words t <word-search>
- "Word search" show-titled-popup ;
-
-: show-vocab-words ( workspace vocab -- )
- "" over words natural-sort f <word-search>
- "Words in " rot vocab-name append show-titled-popup ;
-
-: show-word-usage ( workspace word -- )
- "" over smart-usage f <definition-search>
- "Words and methods using " rot name>> append
- show-titled-popup ;
-
-: help-candidates ( seq -- candidates )
- [ dup >link swap article-title >lower ] { } map>assoc
- sort-values ;
-
-: <help-search> ( string -- gadget )
- all-articles help-candidates
- f [ article-title ] <live-search> ;
-
-: com-search ( workspace -- )
- "" <help-search> "Help search" show-titled-popup ;
-
-: source-file-candidates ( seq -- candidates )
- [ dup <pathname> swap >lower ] { } map>assoc ;
-
-: <source-file-search> ( string files -- gadget )
- source-file-candidates
- f [ pathname-string ] <live-search> ;
-
-: all-source-files ( -- seq )
- source-files get keys natural-sort ;
-
-: com-sources ( workspace -- )
- "" all-source-files <source-file-search>
- "Source file search" show-titled-popup ;
-
-: show-vocab-files ( workspace vocab -- )
- "" over vocab-files <source-file-search>
- "Source files in " rot vocab-name append show-titled-popup ;
-
-: vocab-candidates ( -- candidates )
- all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
-
-: <vocab-search> ( string -- gadget )
- vocab-candidates f [ vocab-name ] <live-search> ;
-
-: com-vocabs ( workspace -- )
- dup current-word <vocab-search>
- "Vocabulary search" show-titled-popup ;
-
-: history-candidates ( seq -- candidates )
- [ dup <input> swap >lower ] { } map>assoc ;
-
-: <history-search> ( string seq -- gadget )
- history-candidates
- f [ input-string ] <live-search> ;
-
-: listener-history ( listener -- seq )
- listener-gadget-input interactor-history <reversed> ;
-
-: com-history ( workspace -- )
- "" over workspace-listener listener-history <history-search>
- "History search" show-titled-popup ;
-
-workspace "toolbar" f {
- { T{ key-down f { C+ } "p" } com-history }
- { T{ key-down f f "TAB" } com-words }
- { T{ key-down f { C+ } "u" } com-vocabs }
- { T{ key-down f { C+ } "e" } com-sources }
- { T{ key-down f { C+ } "h" } com-search }
-} define-command-map
+++ /dev/null
-Support for graphical completion popups
+++ /dev/null
-Graphical developer tools
+++ /dev/null
-USING: editors help.markup help.syntax summary inspector io
-io.styles listener parser prettyprint tools.profiler
-tools.walker ui.commands ui.gadgets.editors ui.gadgets.panes
-ui.gadgets.presentations ui.gadgets.slots ui.operations
-ui.tools.browser ui.tools.interactor ui.tools.inspector
-ui.tools.listener ui.tools.operations ui.tools.profiler
-ui.tools.walker ui.tools.workspace vocabs ;
-IN: ui.tools
-
-ARTICLE: "ui-presentations" "Presentations in the UI"
-"A " { $emphasis "presentation" } " is a graphical view of an object which is directly linked to the object in some way. The help article links you see in the documentation browser are presentations; and if you " { $link see } " a word in the UI listener, all words in the definition will themselves be presentations."
-$nl
-"When you move the mouse over a presentation, it is highlighted with a rectangular border and a short summary of the object being presented is shown in the status bar (the summary is produced using the " { $link summary } " word)."
-$nl
-"Clicking a presentation with the left mouse button invokes a default operation, which usually views the object in some way. For example, clicking a presentation of a word jumps to the word definition in the " { $link "ui-browser" } "."
-$nl
-"Clicking and holding the right mouse button on a presentation displays a popup menu listing available operations."
-$nl
-"Presentation gadgets can be constructed directly using the " { $link <presentation> } " word, and they can also be written to " { $link pane } " gadgets using the " { $link write-object } " word." ;
-
-ARTICLE: "ui-listener" "UI listener"
-"The graphical listener is based around the terminal listener (" { $link "listener" } ") and adds the following features:"
-{ $list
- "Input history"
- { "Completion (see " { $link "ui-completion" } ")" }
- { "Clickable presentations (see " { $link "ui-presentations" } ")" }
-}
-{ $command-map listener-gadget "toolbar" }
-{ $command-map interactor "interactor" }
-{ $command-map source-editor "word" }
-{ $command-map interactor "quotation" }
-{ $heading "Editing commands" }
-"The text editing commands are standard; see " { $link "gadgets-editors" } "."
-{ $heading "Implementation" }
-"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } "), and an input area (instance of " { $link interactor } "), and a stack display kept up to date using a " { $link listener-hook } "." ;
-
-ARTICLE: "ui-inspector" "UI inspector"
-"The graphical inspector builds on the terminal inspector (see " { $link "inspector" } ") and provides in-place editing of slot values."
-$nl
-"To display an object in the UI inspector, use the " { $link inspect } " word from the UI listener, or right-click a presentation and choose " { $strong "Inspect" } " from the menu that appears."
-$nl
-"When the UI inspector is running, all of the terminal inspector words are available, such as " { $link &at } " and " { $link &put } ". Changing slot values using terminal inspector words automatically updates the UI inspector display."
-$nl
-"Slots can also be edited graphically. Clicking the ellipsis to the left of the slot's textual representation displays a slot editor gadget. A text representation of the object can be edited in the slot editor. The parser is used to turn the text representation back into an object. Keep in mind that some structure is lost in the conversion; see " { $link "prettyprint-limitations" } "."
-$nl
-"The slot editor's text editing commands are standard; see " { $link "gadgets-editors" } "."
-$nl
-"The slot editor has a toolbar containing various commands."
-{ $command-map slot-editor "toolbar" }
-{ $command-map inspector-gadget "multi-touch" }
-"The following commands are also available."
-{ $command-map source-editor "word" } ;
-
-ARTICLE: "ui-browser" "UI browser"
-"The browser is used to display Factor code, documentation, and vocabularies."
-{ $command-map browser-gadget "toolbar" }
-{ $command-map browser-gadget "multi-touch" }
-"Browsers are instances of " { $link browser-gadget } "." ;
-
-ARTICLE: "ui-profiler" "UI profiler"
-"The graphical profiler is based on the terminal profiler (see " { $link "profiling" } ") and adds more convenient browsing of profiler results."
-$nl
-"To use the profiler, enter a piece of code in the listener input area and press " { $operation com-profile } "."
-$nl
-"Vocabulary and word presentations in the profiler pane can be clicked on to show profiler results pertaining to the object in question. Clicking a vocabulary in the profiler yields the same output as the " { $link vocab-profile. } " word, and clicking a word yields the same output as the " { $link usage-profile. } " word. Consult " { $link "profiling" } " for details."
-{ $command-map profiler-gadget "toolbar" } ;
-
-ARTICLE: "ui-cocoa" "Functionality specific to Mac OS X"
-"On Mac OS X, the Factor UI offers additional features which integrate with this operating system."
-$nl
-"First, a standard Mac-style menu bar is provided, which offers the bare minimum of what you would expect from a Mac OS X application."
-$nl
-"Dropping a source file onto the Factor icon in the dock runs the source file in the listener."
-$nl
-"If you install " { $strong "Factor.app" } " in your " { $strong "Applications" } " folder, then other applications will be able to call Factor via the System Services feature. For example, you can select some text in " { $strong "TextEdit.app" } ", then invoke the " { $strong "TextEdit->Services->Factor->Evaluate Selection" } " menu item, which will replace the selected text with the result of evaluating it in Factor."
-
-;
-
-ARTICLE: "ui-tool-tutorial" "UI tool tutorial"
-"The following is an example of a typical session with the UI which should give you a taste of its power:"
-{ $list
- { "You decide to refactor some code, and move a few words from a source file you have already loaded, into a new source file." }
- { "You press " { $operation edit } " in the listener, which displays a gadget where you can type part of a loaded file's name, and then press " { $snippet "RET" } " when the correct completion is highlighted. This opens the file in your editor." }
- { "You refactor your words, move them to a new source file, and load the new file using " { $link run-file } "." }
- { "Interactively testing the new code reveals a problem with one particular code snippet, so you enter it in the listener's input area, and press " { $operation walk } " to invoke the single stepper." }
- { "Single stepping through the code makes the problem obvious, so you right-click on a presentation of the broken word in the stepper, and choose " { $strong "Edit" } " from the menu." }
- { "After fixing the problem in the source editor, you right click on the word in the stepper and invoke " { $strong "Reload" } " from the menu." }
-} ;
-
-ARTICLE: "ui-completion-words" "Word completion popup"
-"Clicking a word in the word completion popup displays the word definition in the " { $link "ui-browser" } ". Pressing " { $snippet "RET" } " with a word selected inserts the word name in the listener, along with a " { $link POSTPONE: USE: } " declaration (if necessary)."
-{ $operations \ $operations } ;
-
-ARTICLE: "ui-completion-vocabs" "Vocabulary completion popup"
-"Clicking a vocabulary in the vocabulary completion popup displays a list of words in the vocabulary in another " { $link "ui-completion-words" } ". Pressing " { $snippet "RET" } " adds the vocabulary to the current search path, just as if you invoked " { $link POSTPONE: USE: } "."
-{ $operations "kernel" vocab } ;
-
-ARTICLE: "ui-completion-sources" "Source file completion popup"
-"The source file completion popup lists all source files which have been previously loaded by " { $link run-file } ". Clicking a source file or pressing " { $snippet "RET" } " opens the source file in your editor with " { $link edit } "."
-{ $operations P" " } ;
-
-ARTICLE: "ui-completion" "UI completion popups"
-"Completion popups allow fast access to aspects of the environment. Completion popups can be invoked by clicking the row of buttons along the bottom of the workspace, or via keyboard commands:"
-{ $command-map workspace "toolbar" }
-"A completion popup instantly updates the list of completions as keys are typed. The list of completions can be navigated from the keyboard with the " { $snippet "UP" } " and " { $snippet "DOWN" } " arrow keys. Every completion has a " { $emphasis "primary action" } " and " { $emphasis "secondary action" } ". The primary action is invoked when clicking a completion, and the secondary action is invoked on the currently-selected completion when pressing " { $snippet "RET" } "."
-$nl
-"The primary and secondary actions, along with additional keyboard shortcuts, are documented for some completion popups in the below sections."
-{ $subsection "ui-completion-words" }
-{ $subsection "ui-completion-vocabs" }
-{ $subsection "ui-completion-sources" } ;
-
-ARTICLE: "ui-workspace-keys" "UI keyboard shortcuts"
-{ $command-map workspace "tool-switching" }
-{ $command-map workspace "scrolling" }
-{ $command-map workspace "workflow" }
-{ $command-map workspace "multi-touch" }
-{ $heading "Implementation" }
-"Workspaces are instances of " { $link workspace } "." ;
-
-ARTICLE: "ui-tools" "UI development tools"
-"The Factor development environment can seem rather different from what you are used to, because it is very simple and powerful.."
-$nl
-"To take full advantage of the UI, you should be using a supported text editor. See " { $link "editor" } "."
-{ $subsection "ui-tool-tutorial" }
-{ $subsection "ui-workspace-keys" }
-{ $subsection "ui-presentations" }
-{ $subsection "ui-completion" }
-{ $heading "Tools" }
-"A single-window " { $emphasis "workspace" } " contains the most frequently-used tools:"
-{ $subsection "ui-listener" }
-{ $subsection "ui-browser" }
-{ $subsection "ui-inspector" }
-{ $subsection "ui-profiler" }
-"Additional tools:"
-{ $subsection "ui-walker" }
-{ $subsection "ui.tools.deploy" }
-"Platform-specific features:"
-{ $subsection "ui-cocoa" } ;
-
-ABOUT: "ui-tools"
+++ /dev/null
-USING: ui.tools ui.tools.interactor ui.tools.listener
-ui.tools.search ui.tools.workspace kernel models namespaces
-sequences tools.test ui.gadgets ui.gadgets.buttons
-ui.gadgets.labelled ui.gadgets.presentations
-ui.gadgets.scrollers vocabs tools.test.ui ui accessors ;
-IN: ui.tools.tests
-
-[ f ]
-[
- <gadget> 0 <model> >>model <workspace-tabs> children>> empty?
-] unit-test
-
-[ ] [ <workspace> "w" set ] unit-test
-[ ] [ "w" get com-scroll-up ] unit-test
-[ ] [ "w" get com-scroll-down ] unit-test
-[ t ] [
- "w" get workspace-book gadget-children
- [ tool-scroller ] map sift [ scroller? ] all?
-] unit-test
-[ ] [ "w" get hide-popup ] unit-test
-[ ] [ <gadget> "w" get show-popup ] unit-test
-[ ] [ "w" get hide-popup ] unit-test
-
-[ ] [
- <gadget> "w" get show-popup
- <gadget> "w" get show-popup
- "w" get hide-popup
-] unit-test
-
-[ ] [ <workspace> [ ] with-grafted-gadget ] unit-test
-
-"w" get [
-
- [ ] [ "w" get "kernel" vocab show-vocab-words ] unit-test
-
- [ ] [ notify-queued ] unit-test
-
- [ ] [ "w" get workspace-popup closable-gadget-content
- live-search-list gadget-child "p" set ] unit-test
-
- [ t ] [ "p" get presentation? ] unit-test
-
- [ ] [ "p" get <operations-menu> gadget-child gadget-child "c" set ] unit-test
-
- [ ] [ notify-queued ] unit-test
-
- [ t ] [ "c" get button? ] unit-test
-
- [ ] [
- "w" get workspace-listener listener-gadget-input
- 3 handle-parse-error
- ] unit-test
-
- [ ] [ notify-queued ] unit-test
-] with-grafted-gadget
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs debugger ui.tools.workspace
-ui.tools.operations ui.tools.traceback ui.tools.browser
-ui.tools.inspector ui.tools.listener ui.tools.profiler
-ui.tools.operations inspector io kernel math models namespaces
-prettyprint quotations sequences ui ui.commands ui.gadgets
-ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
-ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
-ui.gadgets.presentations ui.gestures words vocabs.loader
-tools.test tools.vocabs ui.gadgets.buttons ui.gadgets.status-bar
-mirrors ;
-IN: ui.tools
-
-: <workspace-tabs> ( workspace -- tabs )
- model>>
- "tool-switching" workspace command-map commands>>
- [ command-string ] { } assoc>map <enum> >alist
- <toggle-buttons> ;
-
-: <workspace-book> ( workspace -- gadget )
-
- dup
- <stack-display>
- <browser-gadget>
- <inspector-gadget>
- <profiler-gadget>
- 4array
-
- swap model>>
-
- <book> ;
-
-: <workspace> ( -- workspace )
- { 0 1 } workspace new-track
-
- 0 <model> >>model
- <listener-gadget> >>listener
- dup <workspace-book> >>book
-
- dup <workspace-tabs> f track-add
- dup book>> 1/5 track-add
- dup listener>> 4/5 track-add
- dup <toolbar> f track-add ;
-
-: resize-workspace ( workspace -- )
- dup track-sizes over control-value zero? [
- 1/5 1 pick set-nth
- 4/5 2 rot set-nth
- ] [
- 2/3 1 pick set-nth
- 1/3 2 rot set-nth
- ] if relayout ;
-
-M: workspace model-changed
- nip
- dup workspace-listener listener-gadget-output scroll>bottom
- dup resize-workspace
- request-focus ;
-
-[ workspace-window ] ui-hook set-global
-
-: com-listener ( workspace -- ) stack-display select-tool ;
-
-: com-browser ( workspace -- ) browser-gadget select-tool ;
-
-: com-inspector ( workspace -- ) inspector-gadget select-tool ;
-
-: com-profiler ( workspace -- ) profiler-gadget select-tool ;
-
-workspace "tool-switching" f {
- { T{ key-down f { A+ } "1" } com-listener }
- { T{ key-down f { A+ } "2" } com-browser }
- { T{ key-down f { A+ } "3" } com-inspector }
- { T{ key-down f { A+ } "4" } com-profiler }
-} define-command-map
-
-workspace "multi-touch" f {
- { T{ zoom-out-action } com-listener }
- { T{ up-action } refresh-all }
-} define-command-map
-
-\ workspace-window
-H{ { +nullary+ t } } define-command
-
-\ refresh-all
-H{ { +nullary+ t } { +listener+ t } } define-command
-
-workspace "workflow" f {
- { T{ key-down f { C+ } "n" } workspace-window }
- { T{ key-down f f "ESC" } hide-popup }
- { T{ key-down f f "F2" } refresh-all }
-} define-command-map
-
-[
- <workspace> dup "Factor workspace" open-status-window
-] workspace-window-hook set-global
-
-: inspect-continuation ( traceback -- )
- control-value [ inspect ] curry call-listener ;
-
-traceback-gadget "toolbar" f {
- { T{ key-down f f "v" } variables }
- { T{ key-down f f "n" } inspect-continuation }
-} define-command-map
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Traceback gadgets display a continuation in human-readable form
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors continuations kernel models namespaces
- prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
- ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
- ui.gadgets.status-bar ui.gadgets.scrollers ui.gestures sequences
- hashtables inspector ;
-
-IN: ui.tools.traceback
-
-: <callstack-display> ( model -- gadget )
- [ [ continuation-call callstack. ] when* ]
- t "Call stack" <labelled-pane> ;
-
-: <datastack-display> ( model -- gadget )
- [ [ continuation-data stack. ] when* ]
- t "Data stack" <labelled-pane> ;
-
-: <retainstack-display> ( model -- gadget )
- [ [ continuation-retain stack. ] when* ]
- t "Retain stack" <labelled-pane> ;
-
-TUPLE: traceback-gadget < track ;
-
-M: traceback-gadget pref-dim* drop { 550 600 } ;
-
-: <traceback-gadget> ( model -- gadget )
- { 0 1 } traceback-gadget new-track
- swap >>model
-
- dup model>>
- { 1 0 } <track>
- over <datastack-display> 1/2 track-add
- swap <retainstack-display> 1/2 track-add
- 1/3 track-add
-
- dup model>> <callstack-display> 2/3 track-add
-
- dup <toolbar> f track-add ;
-
-: <namestack-display> ( model -- gadget )
- [ [ continuation-name namestack. ] when* ]
- <pane-control> ;
-
-: <variables-gadget> ( model -- gadget )
- <namestack-display> { 400 400 } <limited-scroller> ;
-
-: variables ( traceback -- )
- gadget-model <variables-gadget>
- "Dynamic variables" open-status-window ;
-
-: traceback-window ( continuation -- )
- <model> <traceback-gadget> "Traceback" open-window ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Graphical code single stepper
+++ /dev/null
-IN: ui.tools.walker\r
-USING: help.markup help.syntax ui.commands ui.operations\r
-ui.render tools.walker sequences ;\r
-\r
-ARTICLE: "ui-walker-step" "Stepping through code"\r
-"If the current position points to a word, the various stepping commands behave as follows:"\r
-{ $list\r
- { { $link com-step } " executes the word and moves the current position one word further." }\r
- { { $link com-into } " enters the word's definition, unless it is a primitive, in which case it behaves like " { $link com-step } "." }\r
- { { $link com-out } " executes until the end of the current quotation." }\r
-}\r
-"If the current position points to a literal, the various stepping commands behave as follows:"\r
-{ $list\r
- { { $link com-step } " pushes the literal on the data stack." }\r
- { { $link com-into } " pushes the literal. If it is a quotation, a breakpoint is inserted at the beginning of the quotation, and if it is an array of quotations, a breakpoint is inserted at the beginning of each quotation element." }\r
- { { $link com-out } " executes until the end of the current quotation." }\r
-}\r
-"The behavior of the " { $link com-into } " command is useful when debugging code using combinators. Instead of stepping into the definition of a combinator, which may be quite complex, you can set a breakpoint on the quotation and continue. For example, suppose the following quotation is being walked:"\r
-{ $code "{ 10 20 30 } [ 3 + . ] each" }\r
-"If the current position is on the quotation and " { $link com-into } " is invoked, the following quotation is pushed on the stack:"\r
-{ $code "[ break 3 + . ]" }\r
-"Invoking " { $link com-continue } " will continue execution until the breakpoint is hit, which in this case happens immediately. The stack can then be inspected to verify that the first element of the array, 10, was pushed. Invoking " { $link com-continue } " proceeds until the breakpoint is hit on the second iteration, at which time the top of the stack will contain the value 20. Invoking " { $link com-continue } " a third time will proceed on to the final iteration where 30 is at the top of the stack. Invoking " { $link com-continue } " again will end the walk of this code snippet, since no more iterations remain the quotation will never be called again and the breakpoint will not be hit."\r
-$nl\r
-"The " { $link com-back } " command travels backwards through time, and restore stacks. This does not undo side effects (modifying array entries, writing to files, formatting the hard drive, etc) and therefore can only be used reliably on referentially transparent code." ;\r
-\r
-ARTICLE: "breakpoints" "Setting breakpoints"\r
-"In addition to invoking the walker explicitly through the UI, it is possible to set breakpoints on words. See " { $link "tools.annotations" } "."\r
-$nl\r
-"Breakpoints can be inserted directly into code:"\r
-{ $subsection break }\r
-"Note that because the walker calls various core library and UI words while rendering its own user interface, setting a breakpoint on a word such as " { $link append } " or " { $link draw-gadget } " will hang the UI." ;\r
-\r
-ARTICLE: "ui-walker" "UI walker"\r
-"The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "."\r
-$nl\r
-"Walkers are instances of " { $link walker-gadget } "."\r
-{ $subsection "ui-walker-step" }\r
-{ $subsection "breakpoints" }\r
-{ $command-map walker-gadget "toolbar" } ;\r
-\r
-ABOUT: "ui-walker"\r
+++ /dev/null
-USING: ui.tools.walker tools.test ;
-IN: ui.tools.walker.tests
-
-\ <walker-gadget> must-infer
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel concurrency.messaging inspector
-ui.tools.listener ui.tools.traceback ui.gadgets.buttons
-ui.gadgets.status-bar ui.gadgets.tracks ui.commands ui.gadgets
-models models.filter ui.tools.workspace ui.gestures
-ui.gadgets.labels ui threads namespaces tools.walker assocs
-combinators ;
-IN: ui.tools.walker
-
-TUPLE: walker-gadget < track
-status continuation thread
-traceback
-closing? ;
-
-: walker-command ( walker msg -- )
- swap
- dup thread>> thread-registered?
- [ thread>> send-synchronous drop ]
- [ 2drop ]
- if ;
-
-: com-step ( walker -- ) step walker-command ;
-
-: com-into ( walker -- ) step-into walker-command ;
-
-: com-out ( walker -- ) step-out walker-command ;
-
-: com-back ( walker -- ) step-back walker-command ;
-
-: com-continue ( walker -- ) step-all walker-command ;
-
-: com-abandon ( walker -- ) abandon walker-command ;
-
-M: walker-gadget ungraft*
- [ t >>closing? drop ] [ com-continue ] [ call-next-method ] tri ;
-
-M: walker-gadget focusable-child*
- traceback>> ;
-
-: walker-state-string ( status thread -- string )
- [
- "Thread: " %
- dup thread-name %
- " (" %
- swap {
- { +stopped+ "Stopped" }
- { +suspended+ "Suspended" }
- { +running+ "Running" }
- } at %
- ")" %
- drop
- ] "" make ;
-
-: <thread-status> ( model thread -- gadget )
- [ walker-state-string ] curry <filter> <label-control> ;
-
-: <walker-gadget> ( status continuation thread -- gadget )
- { 0 1 } walker-gadget new-track
- swap >>thread
- swap >>continuation
- swap >>status
- dup continuation>> <traceback-gadget> >>traceback
-
- dup <toolbar> f track-add
- dup status>> self <thread-status> f track-add
- dup traceback>> 1 track-add ;
-
-: walker-help ( -- ) "ui-walker" help-window ;
-
-\ walker-help H{ { +nullary+ t } } define-command
-
-walker-gadget "toolbar" f {
- { T{ key-down f f "s" } com-step }
- { T{ key-down f f "i" } com-into }
- { T{ key-down f f "o" } com-out }
- { T{ key-down f f "b" } com-back }
- { T{ key-down f f "c" } com-continue }
- { T{ key-down f f "a" } com-abandon }
- { T{ key-down f f "d" } close-window }
- { T{ key-down f f "F1" } walker-help }
-} define-command-map
-
-: walker-for-thread? ( thread gadget -- ? )
- {
- { [ dup walker-gadget? not ] [ 2drop f ] }
- { [ dup walker-gadget-closing? ] [ 2drop f ] }
- [ thread>> eq? ]
- } cond ;
-
-: find-walker-window ( thread -- world/f )
- [ swap walker-for-thread? ] curry find-window ;
-
-: walker-window ( status continuation thread -- )
- [ <walker-gadget> ] [ thread-name ] bi open-status-window ;
-
-[
- dup find-walker-window dup
- [ raise-window 3drop ] [ drop [ walker-window ] with-ui ] if
-] show-walker-hook set-global
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Graphical development environment
+++ /dev/null
-IN: ui.tools.workspace.tests
-USING: tools.test ui.tools ;
-
-\ <workspace> must-infer
+++ /dev/null
-! Copyright (C) 2006, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: classes continuations help help.topics kernel models
- sequences ui ui.backend ui.tools.debugger ui.gadgets
- ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
- ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
- ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
- ui.commands ui.gestures assocs arrays namespaces accessors ;
-
-IN: ui.tools.workspace
-
-TUPLE: workspace < track book listener popup ;
-
-: find-workspace ( gadget -- workspace ) [ workspace? ] find-parent ;
-
-SYMBOL: workspace-window-hook
-
-: workspace-window* ( -- workspace ) workspace-window-hook get call ;
-
-: workspace-window ( -- ) workspace-window* drop ;
-
-GENERIC: call-tool* ( arg tool -- )
-
-GENERIC: tool-scroller ( tool -- scroller )
-
-M: gadget tool-scroller drop f ;
-
-: find-tool ( class workspace -- index tool )
- book>> children>> [ class eq? ] with find ;
-
-: show-tool ( class workspace -- tool )
- [ find-tool swap ] keep workspace-book gadget-model
- set-model ;
-
-: select-tool ( workspace class -- ) swap show-tool drop ;
-
-: get-workspace* ( quot -- workspace )
- [ >r dup workspace? r> [ drop f ] if ] curry find-window
- [ dup raise-window gadget-child ]
- [ workspace-window* ] if* ; inline
-
-: get-workspace ( -- workspace ) [ drop t ] get-workspace* ;
-
-: call-tool ( arg class -- )
- get-workspace show-tool call-tool* ;
-
-: get-tool ( class -- gadget )
- get-workspace find-tool nip ;
-
-: help-window ( topic -- )
- [
- <pane> [ [ help ] with-pane ] keep
- { 550 700 } <limited-scroller>
- ] keep
- article-title open-window ;
-
-: hide-popup ( workspace -- )
- dup popup>> track-remove
- f >>popup
- request-focus ;
-
-: show-popup ( gadget workspace -- )
- dup hide-popup
- over >>popup
- over f track-add drop
- request-focus ;
-
-: show-titled-popup ( workspace gadget title -- )
- [ find-workspace hide-popup ] <closable-gadget>
- swap show-popup ;
-
-: debugger-popup ( error workspace -- )
- swap dup compute-restarts
- [ find-workspace hide-popup ] <debugger>
- "Error" show-titled-popup ;
-
-SYMBOL: workspace-dim
-
-{ 600 700 } workspace-dim set-global
-
-M: workspace pref-dim* drop workspace-dim get ;
-
-M: workspace focusable-child*
- dup workspace-popup [ ] [ workspace-listener ] ?if ;
-
-: workspace-page ( workspace -- gadget )
- workspace-book current-page ;
-
-M: workspace tool-scroller ( workspace -- scroller )
- workspace-page tool-scroller ;
-
-: com-scroll-up ( workspace -- )
- tool-scroller [ scroll-up-page ] when* ;
-
-: com-scroll-down ( workspace -- )
- tool-scroller [ scroll-down-page ] when* ;
-
-workspace "scrolling"
-"The current tool's scroll pane can be scrolled from the keyboard."
-{
- { T{ key-down f { C+ } "PAGE_UP" } com-scroll-up }
- { T{ key-down f { C+ } "PAGE_DOWN" } com-scroll-down }
-} define-command-map
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Gadget tree traversal
+++ /dev/null
-IN: ui.traverse.tests
-USING: ui.gadgets ui.gadgets.labels namespaces sequences kernel
-math arrays tools.test io ui.gadgets.panes ui.traverse
-definitions compiler.units ;
-
-M: array gadget-children ;
-
-GENERIC: (flatten-tree) ( node -- )
-
-M: node (flatten-tree)
- node-children [ (flatten-tree) ] each ;
-
-M: object (flatten-tree) , ;
-
-: flatten-tree ( seq -- newseq )
- [ [ (flatten-tree) ] each ] { } make ;
-
-: gadgets-in-range ( frompath topath gadget -- seq )
- gadget-subtree flatten-tree ;
-
-[ { "a" "b" "c" "d" } ] [
- { 0 } { } { "a" "b" "c" "d" } gadgets-in-range
-] unit-test
-
-[ { "a" "b" } ] [
- { } { 1 } { "a" "b" "c" "d" } gadgets-in-range
-] unit-test
-
-[ { "a" } ] [
- { 0 } { 0 } { "a" "b" "c" "d" } gadgets-in-range
-] unit-test
-
-[ { "a" "b" "c" } ] [
- { 0 } { 2 } { "a" "b" "c" "d" } gadgets-in-range
-] unit-test
-
-[ { "a" "b" "c" "d" } ] [
- { 0 } { 3 } { "a" "b" "c" "d" } gadgets-in-range
-] unit-test
-
-[ { "a" "b" "c" "d" } ] [
- { 0 0 } { 0 3 } { { "a" "b" "c" "d" } } gadgets-in-range
-] unit-test
-
-[ { "b" "c" "d" "e" } ] [
- { 0 1 } { 1 } { { "a" "b" "c" "d" } "e" } gadgets-in-range
-] unit-test
-
-[ { "b" "c" "d" "e" "f" } ] [
- { 0 1 } { 1 1 } { { "a" "b" "c" "d" } { "e" "f" "g" } } gadgets-in-range
-] unit-test
-
-[ { "b" "c" "d" { "e" "f" "g" } "h" "i" } ] [
- { 0 1 } { 2 1 } { { "a" "b" "c" "d" } { "e" "f" "g" } { "h" "i" } } gadgets-in-range
-] unit-test
-
-[ { "b" "c" "d" { "e" "f" "g" } "h" } ] [
- { 0 1 } { 2 0 0 } { { "a" "b" "c" "d" } { "e" "f" "g" } { { "h" "i" } "j" } } gadgets-in-range
-] unit-test
-
-[ { "b" "c" "d" { "e" "f" "g" } "h" "i" } ] [
- { 0 1 } { 2 0 1 } { { "a" "b" "c" "d" } { "e" "f" "g" } { { "h" "i" } "j" } } gadgets-in-range
-] unit-test
-
-[ { array gadget-children } forget ] with-compilation-unit
+++ /dev/null
-! Copyright (C) 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences kernel math arrays io ui.gadgets
-generic combinators ;
-IN: ui.traverse
-
-TUPLE: node value children ;
-
-: traverse-step ( path gadget -- path' gadget' )
- >r unclip r> gadget-children ?nth ;
-
-: make-node ( quot -- ) { } make node boa , ; inline
-
-: traverse-to-path ( topath gadget -- )
- dup not [
- 2drop
- ] [
- over empty? [
- nip ,
- ] [
- [
- 2dup gadget-children swap first head-slice %
- tuck traverse-step traverse-to-path
- ] make-node
- ] if
- ] if ;
-
-: traverse-from-path ( frompath gadget -- )
- dup not [
- 2drop
- ] [
- over empty? [
- nip ,
- ] [
- [
- 2dup traverse-step traverse-from-path
- tuck gadget-children swap first 1+ tail-slice %
- ] make-node
- ] if
- ] if ;
-
-: traverse-pre ( frompath gadget -- )
- traverse-step traverse-from-path ;
-
-: (traverse-middle) ( frompath topath gadget -- )
- >r >r first 1+ r> first r> gadget-children <slice> % ;
-
-: traverse-post ( topath gadget -- )
- traverse-step traverse-to-path ;
-
-: traverse-middle ( frompath topath gadget -- )
- [
- 3dup nip traverse-pre
- 3dup (traverse-middle)
- 2dup traverse-post
- 2nip
- ] make-node ;
-
-DEFER: (gadget-subtree)
-
-: traverse-child ( frompath topath gadget -- )
- dup -roll [
- >r >r rest-slice r> r> traverse-step (gadget-subtree)
- ] make-node ;
-
-: (gadget-subtree) ( frompath topath gadget -- )
- {
- { [ dup not ] [ 3drop ] }
- { [ pick empty? pick empty? and ] [ 2nip , ] }
- { [ pick empty? ] [ rot drop traverse-to-path ] }
- { [ over empty? ] [ nip traverse-from-path ] }
- { [ pick first pick first = ] [ traverse-child ] }
- [ traverse-middle ]
- } cond ;
-
-: gadget-subtree ( frompath topath gadget -- seq )
- [ (gadget-subtree) ] { } make ;
-
-M: node gadget-text*
- dup node-children swap node-value gadget-seq-text ;
-
-: gadget-text-range ( frompath topath gadget -- str )
- gadget-subtree gadget-text ;
-
-: gadget-at-path ( parent path -- gadget )
- [ swap nth-gadget ] each ;
+++ /dev/null
-USING: help.markup help.syntax strings quotations debugger
-io.styles namespaces ui.backend ui.gadgets ui.gadgets.worlds
-ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids math.geometry.rect ;
-IN: ui
-
-HELP: windows
-{ $var-description "Global variable holding an association list mapping native window handles to " { $link world } " instances." } ;
-
-{ windows open-window find-window } related-words
-
-HELP: open-window
-{ $values { "gadget" gadget } { "title" string } }
-{ $description "Opens a native window with the specified title." } ;
-
-HELP: set-fullscreen?
-{ $values { "?" "a boolean" } { "gadget" gadget } }
-{ $description "Sets and unsets fullscreen mode for the gadget's world." } ;
-
-HELP: fullscreen?
-{ $values { "gadget" gadget } { "?" "a boolean" } }
-{ $description "Queries the gadget's world to see if it is running in fullscreen mode." } ;
-
-{ fullscreen? set-fullscreen? } related-words
-
-HELP: find-window
-{ $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" "a " { $link world } " or " { $link f } } }
-{ $description "Finds a native window such that the gadget passed to " { $link open-window } " satisfies the quotation, outputting " { $link f } " if no such gadget could be found. The front-most native window is checked first." } ;
-
-HELP: register-window
-{ $values { "world" world } { "handle" "a baackend-specific handle" } }
-{ $description "Adds a window to the global " { $link windows } " variable." }
-{ $notes "This word should only be called by the UI backend. User code can open new windows with " { $link open-window } "." } ;
-
-HELP: unregister-window
-{ $values { "handle" "a baackend-specific handle" } }
-{ $description "Removes a window from the global " { $link windows } " variable." }
-{ $notes "This word should only be called only by the UI backend, and not user code." } ;
-
-HELP: ui
-{ $description "Starts the Factor UI." } ;
-
-HELP: start-ui
-{ $description "Called by the UI backend to initialize the platform-independent parts of UI. This word should be called after the backend is ready to start displaying new windows, and before the event loop starts." } ;
-
-HELP: (open-window)
-{ $values { "world" world } }
-{ $description "Opens a native window containing the given world. This grafts the world by calling " { $link graft } ". Each world can only be displayed in one top-level window at a time." }
-{ $notes "This word should not be called directly by user code. Instead, use " { $link open-window } "." } ;
-
-HELP: ui-try
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation. If it throws an error, opens a window with the error and restores the data stack." }
-{ $notes "This is essentially a graphical variant of " { $link try } "." } ;
-
-ARTICLE: "ui-glossary" "UI glossary"
-{ $table
- { "color specifier"
- { "an array of four elements, all numbers between 0 and 1:"
- { $list
- "red"
- "green"
- "blue"
- "alpha - 0 is completely transparent, 1 is completely opaque"
- }
- }
- }
- { "dimension" "a pair of integers denoting pixel size on screen" }
- { "font specifier"
- { "an array of three elements:"
- { $list
- { "font family - one of " { $snippet "serif" } ", " { $snippet "sans-serif" } " or " { $snippet "monospace" } }
- { "font style - one of " { $link plain } ", " { $link bold } ", " { $link italic } " or " { $link bold-italic } }
- "font size in points"
- }
- }
- }
- { "gadget" { "a graphical element which responds to user input. Gadgets are tuples which (directly or indirectly) inherit from " { $link gadget } "." } }
- { "label specifier" { "a string, " { $link f } " or a gadget. See " { $link "ui.gadgets.buttons" } } }
- { "orientation specifier" { "one of " { $snippet "{ 0 1 }" } " or " { $snippet "{ 1 0 }" } ", with the former denoting vertical orientation and the latter denoting horizontal. Using a vector instead of symbolic constants allows these values to be directly useful in co-ordinate calculations" } }
- { "point" "a pair of integers denoting a pixel location on screen" }
-} ;
-
-ARTICLE: "building-ui" "Building user interfaces"
-"A gadget is a graphical element which responds to user input. Gadgets are implemented as tuples which (directly or indirectly) inherit from " { $link gadget } ", which in turn inherits from " { $link rect } "."
-{ $subsection gadget }
-"Gadgets are arranged in a hierarchy, and all visible gadgets except for instances of " { $link world } " are contained in a parent gadget, stored in the " { $link gadget-parent } " slot."
-{ $subsection "ui-geometry" }
-{ $subsection "ui-layouts" }
-{ $subsection "gadgets" }
-{ $subsection "ui-windows" }
-{ $see-also "models" } ;
-
-ARTICLE: "gadgets" "Pre-made UI gadgets"
-{ $subsection "ui.gadgets.labels" }
-{ $subsection "gadgets-polygons" }
-{ $subsection "ui.gadgets.borders" }
-{ $subsection "ui.gadgets.labelled" }
-{ $subsection "ui.gadgets.buttons" }
-{ $subsection "ui.gadgets.sliders" }
-{ $subsection "ui.gadgets.scrollers" }
-{ $subsection "gadgets-editors" }
-{ $subsection "ui.gadgets.panes" }
-{ $subsection "ui.gadgets.presentations" }
-{ $subsection "ui.gadgets.lists" } ;
-
-ARTICLE: "ui-geometry" "Gadget geometry"
-"The " { $link gadget } " class inherits from the " { $link rect } " class, and thus all gadgets have a bounding box:"
-{ $subsection rect }
-"Rectangles can be taken apart:"
-{ $subsection rect-loc }
-{ $subsection rect-dim }
-{ $subsection rect-bounds }
-{ $subsection rect-extent }
-"New rectangles can be created:"
-{ $subsection <zero-rect> }
-{ $subsection <rect> }
-{ $subsection <extent-rect> }
-"More utility words for working with rectangles:"
-{ $subsection offset-rect }
-{ $subsection rect-intersect }
-{ $subsection intersects? }
-"A gadget's bounding box is always relative to its parent:"
-{ $subsection gadget-parent }
-"Word for converting from a child gadget's co-ordinate system to a parent's:"
-{ $subsection relative-loc }
-{ $subsection screen-loc }
-"Hit testing:"
-{ $subsection pick-up }
-{ $subsection children-on } ;
-
-ARTICLE: "ui-windows" "Top-level windows"
-"Opening a top-level window:"
-{ $subsection open-window }
-"Finding top-level windows:"
-{ $subsection find-window }
-"Top-level windows are stored in a global variable:"
-{ $subsection windows }
-"When a gadget is displayed in a top-level window, or added to a parent which is already showing in a top-level window, a generic word is called allowing the gadget to perform initialization tasks:"
-{ $subsection graft* }
-"When the gadget is removed from a parent shown in a top-level window, or when the top-level window is closed, a corresponding generic word is called to clean up:"
-{ $subsection ungraft* }
-"The root of the gadget hierarchy in a window is a special gadget which is rarely operated on directly, but it is helpful to know it exists:"
-{ $subsection world } ;
-
-ARTICLE: "ui-backend" "Developing UI backends"
-"None of the words documented in this section should be called directly by user code. They are only of interest when developing new UI backends."
-{ $subsection "ui-backend-init" }
-{ $subsection "ui-backend-windows" }
-"UI backends may implement the " { $link "clipboard-protocol" } "." ;
-
-ARTICLE: "ui-backend-init" "UI initialization and the event loop"
-"An UI backend is required to define a word to start the UI:"
-{ $subsection ui }
-"This word should contain backend initialization, together with some boilerplate:"
-{ $code
- "IN: shells"
- ""
- ": ui"
- " ... backend-specific initialization ..."
- " start-ui"
- " ... more backend-specific initialization ..."
- " ... start event loop here ... ;"
-}
-"The above word must call the following:"
-{ $subsection start-ui }
-"The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down."
-$nl
-"The event loop must not block, since otherwise other Factor threads and I/O will not run. Instead, it should poll for pending events, then call " { $link ui-wait } "." ;
-
-ARTICLE: "ui-backend-windows" "UI backend window management"
-"The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:"
-{ $subsection open-world-window }
-"This word should create a native window, store some kind of handle in the " { $link world-handle } " slot, then call two words:"
-{ $subsection register-window }
-"The following words must also be implemented:"
-{ $subsection set-title }
-{ $subsection raise-window }
-"When a world needs to be redrawn, the UI will call a word automatically:"
-{ $subsection draw-world }
-"This word can also be called directly if the UI backend is notified by the window system that window contents have been invalidated. Before and after drawing, two words are called, which the UI backend must implement:"
-{ $subsection select-gl-context }
-{ $subsection flush-gl-context }
-"If the user clicks the window's close box, you must call the following word:"
-{ $subsection close-window } ;
-
-HELP: raise-window
-{ $values { "gadget" gadget } }
-{ $description "Makes the native window containing the given gadget the front-most window." } ;
-
-ARTICLE: "ui-layouts" "Gadget hierarchy and layouts"
-"A layout gadget is a gadget whose sole purpose is to contain other gadgets. Layout gadgets position and resize children according to a certain policy, taking the preferred size of the children into account. Gadget hierarchies are constructed by building up nested layouts."
-{ $subsection "ui-layout-basics" }
-{ $subsection "ui-layout-combinators" }
-"Common layout gadgets:"
-{ $subsection "ui-pack-layout" }
-{ $subsection "ui-track-layout" }
-{ $subsection "ui-grid-layout" }
-{ $subsection "ui-frame-layout" }
-{ $subsection "ui-book-layout" }
-"Advanced topics:"
-{ $subsection "ui-null-layout" }
-{ $subsection "ui-incremental-layout" }
-{ $subsection "ui-layout-impl" }
-{ $see-also "ui.gadgets.borders" } ;
-
-ARTICLE: "ui-layout-basics" "Layout basics"
-"Gadgets are arranged in a hierarchy, and all visible gadgets except for instances of " { $link world } " are contained in a parent gadget."
-$nl
-"Managing the gadget hierarchy:"
-{ $subsection add-gadget }
-{ $subsection unparent }
-{ $subsection add-gadgets }
-{ $subsection clear-gadget }
-"Working with gadget children:"
-{ $subsection gadget-children }
-{ $subsection gadget-child }
-{ $subsection nth-gadget }
-{ $subsection each-child }
-{ $subsection child? }
-"Working with gadget parents:"
-{ $subsection parents }
-{ $subsection each-parent }
-{ $subsection find-parent }
-"Adding children, removing children and performing certain other operations initiates relayout requests automatically. In other cases, relayout may have to be triggered explicitly. There is no harm from doing this several times in a row as consecutive relayout requests are coalesced."
-{ $subsection relayout }
-{ $subsection relayout-1 }
-"Gadgets implement a generic word to inform their parents of their preferred size:"
-{ $subsection pref-dim* }
-"To get a gadget's preferred size, do not call the above word, instead use " { $link pref-dim } ", which caches the result." ;
-
-ARTICLE: "ui-layout-combinators" "Creating layouts using combinators"
-"The " { $link make } " combinator provides a convenient way of constructing sequences by keeping the intermediate sequence off the stack until construction is done. The " { $link , } " and " { $link % } " words operate on this implicit sequence, reducing stack noise."
-$nl
-"Similar tools exist for constructing complex gadget hierarchies. Different words are used for different types of gadgets; see " { $link "ui-pack-layout" } ", " { $link "ui-track-layout" } " and " { $link "ui-frame-layout" } " for specifics. This section documents their common factors."
-;
-
-ARTICLE: "ui-null-layout" "Manual layouts"
-"When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually:"
-{ $subsection set-rect-loc } ;
-
-ARTICLE: "ui-layout-impl" "Implementing layout gadgets"
-"The relayout process proceeds top-down, with parents laying out their children, which in turn lay out their children. Custom layout policy is implemented by defining a method on a generic word:"
-{ $subsection layout* }
-"When a " { $link layout* } " method is called, the size and location of the gadget has already been determined by its parent, and the method's job is to lay out the gadget's children. Children can be positioned and resized with a pair of words:"
-{ $subsection set-rect-loc }
-"Some assorted utility words which are useful for implementing layout logic:"
-{ $subsection pref-dim }
-{ $subsection pref-dims }
-{ $subsection prefer }
-{ $subsection max-dim }
-{ $subsection dim-sum }
-{ $warning
- "When implementing the " { $link layout* } " generic word for a gadget which inherits from another layout, the " { $link children-on } " word might have to be re-implemented as well."
- $nl
- "For example, suppose you want a " { $link grid } " layout which also displays a popup gadget on top. The implementation of " { $link children-on } " for the " { $link grid } " class determines which children of the grid are visible at one time, and this will never include your popup, so it will not be rendered, nor will it respond to gestures. The solution is to re-implement " { $link children-on } " on your class."
-} ;
-
-ARTICLE: "new-gadgets" "Implementing new gadgets"
-"One of the goals of the Factor UI is to minimize the need to implement new types of gadgets by offering a highly reusable, orthogonal set of building blocks. However, in some cases implementing a new type of gadget is necessary, for example when writing a graphical visualization."
-$nl
-"Bare gadgets can be constructed directly, which is useful if all you need is a custom appearance with no further behavior (see " { $link "ui-pen-protocol" } "):"
-{ $subsection <gadget> }
-"New gadgets are defined as subclasses of an existing gadget type, perhaps even " { $link gadget } " itself. A parametrized constructor should be used to construct subclasses:"
-{ $subsection new-gadget }
-"Further topics:"
-{ $subsection "ui-gestures" }
-{ $subsection "ui-paint" }
-{ $subsection "ui-control-impl" }
-{ $subsection "clipboard-protocol" }
-{ $see-also "ui-layout-impl" } ;
-
-ARTICLE: "ui" "UI framework"
-{ $subsection "ui-glossary" }
-{ $subsection "building-ui" }
-{ $subsection "new-gadgets" }
-{ $subsection "ui-backend" } ;
-
-ABOUT: "ui"
+++ /dev/null
-! Copyright (C) 2006, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs io kernel math models namespaces
-prettyprint dlists deques sequences threads sequences words
-debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
-ui.gestures ui.backend ui.render continuations init combinators
-hashtables concurrency.flags sets accessors ;
-IN: ui
-
-! Assoc mapping aliens to gadgets
-SYMBOL: windows
-
-SYMBOL: stop-after-last-window?
-
-: event-loop? ( -- ? )
- {
- { [ stop-after-last-window? get not ] [ t ] }
- { [ graft-queue deque-empty? not ] [ t ] }
- { [ windows get-global empty? not ] [ t ] }
- [ f ]
- } cond ;
-
-: event-loop ( -- ) [ event-loop? ] [ do-events ] [ ] while ;
-
-: window ( handle -- world ) windows get-global at ;
-
-: window-focus ( handle -- gadget ) window world-focus ;
-
-: register-window ( world handle -- )
- #! Add the new window just below the topmost window. Why?
- #! So that if the new window doesn't actually receive focus
- #! (eg, we're using focus follows mouse and the mouse is not
- #! in the new window when it appears) Factor doesn't get
- #! confused and send workspace operations to the new window,
- #! etc.
- swap 2array windows get-global push
- windows get-global dup length 1 >
- [ [ length 1- dup 1- ] keep exchange ] [ drop ] if ;
-
-: unregister-window ( handle -- )
- windows global [ [ first = not ] with filter ] change-at ;
-
-: raised-window ( world -- )
- windows get-global
- [ [ second eq? ] with find drop ] keep
- [ nth ] [ delete-nth ] [ nip ] 2tri push ;
-
-: focus-gestures ( new old -- )
- drop-prefix <reversed>
- T{ lose-focus } swap each-gesture
- T{ gain-focus } swap each-gesture ;
-
-: focus-world ( world -- )
- t over set-world-focused?
- dup raised-window
- focus-path f focus-gestures ;
-
-: unfocus-world ( world -- )
- f over set-world-focused?
- focus-path f swap focus-gestures ;
-
-M: world graft*
- dup (open-window)
- dup world-title over set-title
- request-focus ;
-
-: reset-world ( world -- )
- #! This is used when a window is being closed, but also
- #! when restoring saved worlds on image startup.
- dup world-fonts clear-assoc
- dup unfocus-world
- f swap set-world-handle ;
-
-M: world ungraft*
- dup free-fonts
- dup hand-clicked close-global
- dup hand-gadget close-global
- dup world-handle (close-window)
- reset-world ;
-
-: find-window ( quot -- world )
- windows get values
- [ gadget-child swap call ] with find-last nip ; inline
-
-SYMBOL: ui-hook
-
-: init-ui ( -- )
- <dlist> \ graft-queue set-global
- <dlist> \ layout-queue set-global
- V{ } clone windows set-global ;
-
-: restore-gadget-later ( gadget -- )
- dup gadget-graft-state {
- { { f f } [ ] }
- { { f t } [ ] }
- { { t t } [
- { f f } over set-gadget-graft-state
- ] }
- { { t f } [
- dup unqueue-graft
- { f f } over set-gadget-graft-state
- ] }
- } case graft-later ;
-
-: restore-gadget ( gadget -- )
- dup restore-gadget-later
- gadget-children [ restore-gadget ] each ;
-
-: restore-world ( world -- )
- dup reset-world restore-gadget ;
-
-: restore-windows ( -- )
- windows get [ values ] keep delete-all
- [ restore-world ] each
- forget-rollover ;
-
-: restore-windows? ( -- ? )
- windows get empty? not ;
-
-: update-hand ( world -- )
- dup hand-world get-global eq?
- [ hand-loc get-global swap move-hand ] [ drop ] if ;
-
-: layout-queued ( -- seq )
- [
- in-layout? on
- layout-queue [
- dup layout find-world [ , ] when*
- ] slurp-deque
- ] { } make prune ;
-
-: redraw-worlds ( seq -- )
- [ dup update-hand draw-world ] each ;
-
-: notify ( gadget -- )
- dup gadget-graft-state
- dup first { f f } { t t } ?
- pick set-gadget-graft-state {
- { { f t } [ dup activate-control graft* ] }
- { { t f } [ dup deactivate-control ungraft* ] }
- } case ;
-
-: notify-queued ( -- )
- graft-queue [ notify ] slurp-deque ;
-
-: update-ui ( -- )
- [ notify-queued layout-queued redraw-worlds ] assert-depth ;
-
-: ui-wait ( -- )
- 10 sleep ;
-
-: ui-try ( quot -- ) [ ui-error ] recover ;
-
-SYMBOL: ui-thread
-
-: ui-running ( quot -- )
- t \ ui-running set-global
- [ f \ ui-running set-global ] [ ] cleanup ; inline
-
-: ui-running? ( -- ? )
- \ ui-running get-global ;
-
-: update-ui-loop ( -- )
- ui-running? ui-thread get-global self eq? and [
- ui-notify-flag get lower-flag
- [ update-ui ] ui-try
- update-ui-loop
- ] when ;
-
-: start-ui-thread ( -- )
- [ self ui-thread set-global update-ui-loop ]
- "UI update" spawn drop ;
-
-: open-world-window ( world -- )
- dup pref-dim over (>>dim) dup relayout graft ;
-
-: open-window ( gadget title -- )
- f <world> open-world-window ;
-
-: set-fullscreen? ( ? gadget -- )
- find-world set-fullscreen* ;
-
-: fullscreen? ( gadget -- ? )
- find-world fullscreen* ;
-
-: raise-window ( gadget -- )
- find-world raise-window* ;
-
-HOOK: close-window ui-backend ( gadget -- )
-
-M: object close-window
- find-world [ ungraft ] when* ;
-
-: start-ui ( -- )
- restore-windows? [
- restore-windows
- ] [
- init-ui ui-hook get call
- ] if
- notify-ui-thread start-ui-thread ;
-
-[
- f \ ui-running set-global
- <flag> ui-notify-flag set-global
-] "ui" add-init-hook
-
-HOOK: ui ui-backend ( -- )
-
-MAIN: ui
-
-: with-ui ( quot -- )
- ui-running? [
- call
- ] [
- f windows set-global
- [
- ui-hook set
- stop-after-last-window? on
- ui
- ] with-scope
- ] if ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2005, 2006 Doug Coleman.
-! Portions copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings arrays assocs ui
-ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
-ui.gestures io kernel math math.vectors namespaces
-sequences strings vectors words windows.kernel32 windows.gdi32
-windows.user32 windows.opengl32 windows.messages windows.types
-windows.nt windows threads libc combinators continuations
-command-line shuffle opengl ui.render unicode.case ascii
-math.bitfields locals symbols accessors math.geometry.rect ;
-IN: ui.windows
-
-SINGLETON: windows-ui-backend
-
-: crlf>lf ( str -- str' )
- CHAR: \r swap remove ;
-
-: lf>crlf ( str -- str' )
- [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
-
-: enum-clipboard ( -- seq )
- 0
- [ EnumClipboardFormats win32-error dup dup 0 > ]
- [ ]
- [ drop ]
- produce nip ;
-
-: with-clipboard ( quot -- )
- f OpenClipboard win32-error=0/f
- call
- CloseClipboard win32-error=0/f ; inline
-
-: paste ( -- str )
- [
- CF_UNICODETEXT IsClipboardFormatAvailable zero? [
- ! nothing to paste
- ""
- ] [
- CF_UNICODETEXT GetClipboardData dup win32-error=0/f
- dup GlobalLock dup win32-error=0/f
- GlobalUnlock win32-error=0/f
- utf16n alien>string
- ] if
- ] with-clipboard
- crlf>lf ;
-
-: copy ( str -- )
- lf>crlf [
- utf16n string>alien
- EmptyClipboard win32-error=0/f
- GMEM_MOVEABLE over length 1+ GlobalAlloc
- dup win32-error=0/f
-
- dup GlobalLock dup win32-error=0/f
- swapd byte-array>memory
- dup GlobalUnlock win32-error=0/f
- CF_UNICODETEXT swap SetClipboardData win32-error=0/f
- ] with-clipboard ;
-
-TUPLE: pasteboard ;
-C: <pasteboard> pasteboard
-
-M: pasteboard clipboard-contents drop paste ;
-M: pasteboard set-clipboard-contents drop copy ;
-
-: init-clipboard ( -- )
- <pasteboard> clipboard set-global
- <clipboard> selection set-global ;
-
-! world-handle is a <win>
-TUPLE: win hWnd hDC hRC world title ;
-C: <win> win
-
-SYMBOLS: msg-obj class-name-ptr mouse-captured ;
-
-: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
-: ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
-
-: get-RECT-top-left ( RECT -- x y )
- [ RECT-left ] keep RECT-top ;
-
-: get-RECT-dimensions ( RECT -- x y width height )
- [ get-RECT-top-left ] keep
- [ RECT-right ] keep [ RECT-left - ] keep
- [ RECT-bottom ] keep RECT-top - ;
-
-: handle-wm-paint ( hWnd uMsg wParam lParam -- )
- #! wParam and lParam are unused
- #! only paint if width/height both > 0
- 3drop window relayout-1 yield ;
-
-: handle-wm-size ( hWnd uMsg wParam lParam -- )
- 2nip
- [ lo-word ] keep hi-word 2array
- dup { 0 0 } = [ 2drop ] [ swap window (>>dim) ] if ;
-
-: handle-wm-move ( hWnd uMsg wParam lParam -- )
- 2nip
- [ lo-word ] keep hi-word 2array
- swap window (>>window-loc) ;
-
-: wm-keydown-codes ( -- key )
- H{
- { 8 "BACKSPACE" }
- { 9 "TAB" }
- { 13 "RET" }
- { 27 "ESC" }
- { 33 "PAGE_UP" }
- { 34 "PAGE_DOWN" }
- { 35 "END" }
- { 36 "HOME" }
- { 37 "LEFT" }
- { 38 "UP" }
- { 39 "RIGHT" }
- { 40 "DOWN" }
- { 45 "INSERT" }
- { 46 "DELETE" }
- { 112 "F1" }
- { 113 "F2" }
- { 114 "F3" }
- { 115 "F4" }
- { 116 "F5" }
- { 117 "F6" }
- { 118 "F7" }
- { 119 "F8" }
- { 120 "F9" }
- { 121 "F10" }
- { 122 "F11" }
- { 123 "F12" }
- } ;
-
-: key-state-down? ( key -- ? )
- GetKeyState 16 bit? ;
-
-: left-shift? ( -- ? ) VK_LSHIFT key-state-down? ;
-: left-ctrl? ( -- ? ) VK_LCONTROL key-state-down? ;
-: left-alt? ( -- ? ) VK_LMENU key-state-down? ;
-: right-shift? ( -- ? ) VK_RSHIFT key-state-down? ;
-: right-ctrl? ( -- ? ) VK_RCONTROL key-state-down? ;
-: right-alt? ( -- ? ) VK_RMENU key-state-down? ;
-: shift? ( -- ? ) left-shift? right-shift? or ;
-: ctrl? ( -- ? ) left-ctrl? right-ctrl? or ;
-: alt? ( -- ? ) left-alt? right-alt? or ;
-: caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ;
-
-: switch-case ( seq -- seq )
- dup first CHAR: a >= [ >upper ] [ >lower ] if ;
-
-: switch-case? ( -- ? ) shift? caps-lock? xor not ;
-
-: key-modifiers ( -- seq )
- [
- shift? [ S+ , ] when
- ctrl? [ C+ , ] when
- alt? [ A+ , ] when
- ] { } make [ empty? not ] keep f ? ;
-
-: exclude-keys-wm-keydown
- H{
- { 16 "SHIFT" }
- { 17 "CTRL" }
- { 18 "ALT" }
- { 20 "CAPS-LOCK" }
- } ;
-
-: exclude-keys-wm-char
- ! Values are ignored
- H{
- { 8 "BACKSPACE" }
- { 9 "TAB" }
- { 13 "RET" }
- { 27 "ESC" }
- } ;
-
-: exclude-key-wm-keydown? ( n -- bool )
- exclude-keys-wm-keydown key? ;
-
-: exclude-key-wm-char? ( n -- bool )
- exclude-keys-wm-char key? ;
-
-: keystroke>gesture ( n -- mods sym ? )
- dup wm-keydown-codes at* [
- nip >r key-modifiers r> t
- ] [
- drop 1string >r key-modifiers r>
- C+ pick member? >r A+ pick member? r> or [
- shift? [ >lower ] unless f
- ] [
- switch-case? [ switch-case ] when t
- ] if
- ] if ;
-
-:: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
- wParam exclude-key-wm-keydown? [
- wParam keystroke>gesture <key-down>
- hWnd window-focus send-gesture drop
- ] unless ;
-
-:: handle-wm-char ( hWnd uMsg wParam lParam -- )
- wParam exclude-key-wm-char? ctrl? alt? xor or [
- wParam 1string
- hWnd window-focus user-input
- ] unless ;
-
-:: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
- wParam keystroke>gesture <key-up>
- hWnd window-focus send-gesture drop ;
-
-:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
- ? hwnd window set-world-active?
- hwnd uMsg wParam lParam DefWindowProc ;
-
-: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
- {
- { [ over SC_MINIMIZE = ] [ f set-window-active ] }
- { [ over SC_RESTORE = ] [ t set-window-active ] }
- { [ over SC_MAXIMIZE = ] [ t set-window-active ] }
- { [ dup alpha? ] [ 4drop 0 ] }
- { [ t ] [ DefWindowProc ] }
- } cond ;
-
-: cleanup-window ( handle -- )
- dup win-title [ free ] when*
- dup win-hRC wglDeleteContext win32-error=0/f
- dup win-hWnd swap win-hDC ReleaseDC win32-error=0/f ;
-
-M: windows-ui-backend (close-window)
- dup win-hWnd unregister-window
- dup cleanup-window
- win-hWnd DestroyWindow win32-error=0/f ;
-
-: handle-wm-close ( hWnd uMsg wParam lParam -- )
- 3drop window ungraft ;
-
-: handle-wm-set-focus ( hWnd uMsg wParam lParam -- )
- 3drop window [ focus-world ] when* ;
-
-: handle-wm-kill-focus ( hWnd uMsg wParam lParam -- )
- 3drop window [ unfocus-world ] when* ;
-
-: message>button ( uMsg -- button down? )
- {
- { [ dup WM_LBUTTONDOWN = ] [ drop 1 t ] }
- { [ dup WM_LBUTTONUP = ] [ drop 1 f ] }
- { [ dup WM_MBUTTONDOWN = ] [ drop 2 t ] }
- { [ dup WM_MBUTTONUP = ] [ drop 2 f ] }
- { [ dup WM_RBUTTONDOWN = ] [ drop 3 t ] }
- { [ dup WM_RBUTTONUP = ] [ drop 3 f ] }
-
- { [ dup WM_NCLBUTTONDOWN = ] [ drop 1 t ] }
- { [ dup WM_NCLBUTTONUP = ] [ drop 1 f ] }
- { [ dup WM_NCMBUTTONDOWN = ] [ drop 2 t ] }
- { [ dup WM_NCMBUTTONUP = ] [ drop 2 f ] }
- { [ dup WM_NCRBUTTONDOWN = ] [ drop 3 t ] }
- { [ dup WM_NCRBUTTONUP = ] [ drop 3 f ] }
- } cond ;
-
-! If the user clicks in the window border ("non-client area")
-! Windows sends us an NC[LMR]BUTTONDOWN message; but if the
-! mouse is subsequently released outside the NC area, we receive
-! a [LMR]BUTTONUP message and Factor can get confused. So we
-! ignore BUTTONUP's that are a result of an NC*BUTTONDOWN.
-SYMBOL: nc-buttons
-
-: handle-wm-ncbutton ( hWnd uMsg wParam lParam -- )
- 2drop nip
- message>button nc-buttons get
- swap [ push ] [ delete ] if ;
-
-: >lo-hi ( WORD -- array ) [ lo-word ] keep hi-word 2array ;
-: mouse-wheel ( lParam -- array ) >lo-hi [ sgn neg ] map ;
-
-: mouse-absolute>relative ( lparam handle -- array )
- >r >lo-hi r>
- "RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
- get-RECT-top-left 2array v- ;
-
-: mouse-event>gesture ( uMsg -- button )
- key-modifiers swap message>button
- [ <button-down> ] [ <button-up> ] if ;
-
-: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
- nip >r mouse-event>gesture r> >lo-hi rot window ;
-
-: set-capture ( hwnd -- )
- mouse-captured get [
- drop
- ] [
- [ SetCapture drop ] keep
- mouse-captured set
- ] if ;
-
-: release-capture ( -- )
- ReleaseCapture win32-error=0/f
- mouse-captured off ;
-
-: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
- >r >r
- over set-capture
- dup message>button drop nc-buttons get delete
- r> r> prepare-mouse send-button-down ;
-
-: handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
- mouse-captured get [ release-capture ] when
- pick message>button drop dup nc-buttons get member? [
- nc-buttons get delete 4drop
- ] [
- drop prepare-mouse send-button-up
- ] if ;
-
-: make-TRACKMOUSEEVENT ( hWnd -- alien )
- "TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
- "TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ;
-
-: handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
- 2nip
- over make-TRACKMOUSEEVENT
- TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags
- 0 over set-TRACKMOUSEEVENT-dwHoverTime
- TrackMouseEvent drop
- >lo-hi swap window move-hand fire-motion ;
-
-: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
- >r nip r>
- pick mouse-absolute>relative >r mouse-wheel r> rot window send-wheel ;
-
-: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
- #! message sent if windows needs application to stop dragging
- 4drop release-capture ;
-
-: handle-wm-mouseleave ( hWnd uMsg wParam lParam -- )
- #! message sent if mouse leaves main application
- 4drop forget-rollover ;
-
-SYMBOL: wm-handlers
-
-H{ } clone wm-handlers set-global
-
-: add-wm-handler ( quot wm -- )
- dup array?
- [ [ execute add-wm-handler ] with each ]
- [ wm-handlers get-global set-at ] if ;
-
-[ handle-wm-close 0 ] WM_CLOSE add-wm-handler
-[ 4dup handle-wm-paint DefWindowProc ] WM_PAINT add-wm-handler
-
-[ handle-wm-size 0 ] WM_SIZE add-wm-handler
-[ handle-wm-move 0 ] WM_MOVE add-wm-handler
-
-[ 4dup handle-wm-keydown DefWindowProc ] { WM_KEYDOWN WM_SYSKEYDOWN } add-wm-handler
-[ 4dup handle-wm-char DefWindowProc ] { WM_CHAR WM_SYSCHAR } add-wm-handler
-[ 4dup handle-wm-keyup DefWindowProc ] { WM_KEYUP WM_SYSKEYUP } add-wm-handler
-
-[ handle-wm-syscommand ] WM_SYSCOMMAND add-wm-handler
-[ handle-wm-set-focus 0 ] WM_SETFOCUS add-wm-handler
-[ handle-wm-kill-focus 0 ] WM_KILLFOCUS add-wm-handler
-
-[ handle-wm-buttondown 0 ] WM_LBUTTONDOWN add-wm-handler
-[ handle-wm-buttondown 0 ] WM_MBUTTONDOWN add-wm-handler
-[ handle-wm-buttondown 0 ] WM_RBUTTONDOWN add-wm-handler
-[ handle-wm-buttonup 0 ] WM_LBUTTONUP add-wm-handler
-[ handle-wm-buttonup 0 ] WM_MBUTTONUP add-wm-handler
-[ handle-wm-buttonup 0 ] WM_RBUTTONUP add-wm-handler
-
-[ 4dup handle-wm-ncbutton DefWindowProc ]
-{ WM_NCLBUTTONDOWN WM_NCMBUTTONDOWN WM_NCRBUTTONDOWN
-WM_NCLBUTTONUP WM_NCMBUTTONUP WM_NCRBUTTONUP }
-add-wm-handler
-
-[ nc-buttons get-global delete-all DefWindowProc ]
-{ WM_EXITSIZEMOVE WM_EXITMENULOOP } add-wm-handler
-
-[ handle-wm-mousemove 0 ] WM_MOUSEMOVE add-wm-handler
-[ handle-wm-mousewheel 0 ] WM_MOUSEWHEEL add-wm-handler
-[ handle-wm-cancelmode 0 ] WM_CANCELMODE add-wm-handler
-[ handle-wm-mouseleave 0 ] WM_MOUSELEAVE add-wm-handler
-
-SYMBOL: trace-messages?
-
-! return 0 if you handle the message, else just let DefWindowProc return its val
-: ui-wndproc ( -- object )
- "uint" { "void*" "uint" "long" "long" } "stdcall" [
- [
- pick
- trace-messages? get-global [ dup windows-message-name name>> print flush ] when
- wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
- ] ui-try
- ] alien-callback ;
-
-: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
-
-M: windows-ui-backend do-events
- msg-obj get-global
- dup peek-message? [ drop ui-wait ] [
- [ TranslateMessage drop ]
- [ DispatchMessage drop ] bi
- ] if ;
-
-: register-wndclassex ( -- class )
- "WNDCLASSEX" <c-object>
- f GetModuleHandle
- class-name-ptr get-global
- pick GetClassInfoEx zero? [
- "WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize
- { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style
- ui-wndproc over set-WNDCLASSEX-lpfnWndProc
- 0 over set-WNDCLASSEX-cbClsExtra
- 0 over set-WNDCLASSEX-cbWndExtra
- f GetModuleHandle over set-WNDCLASSEX-hInstance
- f GetModuleHandle "fraptor" utf16n string>alien LoadIcon
- over set-WNDCLASSEX-hIcon
- f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
-
- class-name-ptr get-global over set-WNDCLASSEX-lpszClassName
- RegisterClassEx dup win32-error=0/f
- ] when ;
-
-: adjust-RECT ( RECT -- )
- style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
-
-: make-RECT ( world -- RECT )
- dup window-loc>> { 40 40 } vmax dup rot rect-dim v+
- "RECT" <c-object>
- over first over set-RECT-right
- swap second over set-RECT-bottom
- over first over set-RECT-left
- swap second over set-RECT-top ;
-
-: make-adjusted-RECT ( rect -- RECT )
- make-RECT dup adjust-RECT ;
-
-: create-window ( rect -- hwnd )
- make-adjusted-RECT
- >r class-name-ptr get-global f r>
- >r >r >r ex-style r> r>
- { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
- r> get-RECT-dimensions
- f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
-
-: show-window ( hWnd -- )
- dup SW_SHOW ShowWindow drop ! always succeeds
- dup SetForegroundWindow drop
- SetFocus drop ;
-
-: init-win32-ui ( -- )
- V{ } clone nc-buttons set-global
- "MSG" malloc-object msg-obj set-global
- "Factor-window" utf16n malloc-string class-name-ptr set-global
- register-wndclassex drop
- GetDoubleClickTime double-click-timeout set-global ;
-
-: cleanup-win32-ui ( -- )
- class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
- msg-obj get-global [ free ] when*
- f class-name-ptr set-global
- f msg-obj set-global ;
-
-: setup-pixel-format ( hdc -- )
- 16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
- swapd SetPixelFormat win32-error=0/f ;
-
-: get-dc ( hWnd -- hDC ) GetDC dup win32-error=0/f ;
-
-: get-rc ( hDC -- hRC )
- dup wglCreateContext dup win32-error=0/f
- [ wglMakeCurrent win32-error=0/f ] keep ;
-
-: setup-gl ( hwnd -- hDC hRC )
- get-dc dup setup-pixel-format dup get-rc ;
-
-M: windows-ui-backend (open-window) ( world -- )
- [ create-window dup setup-gl ] keep
- [ f <win> ] keep
- [ swap win-hWnd register-window ] 2keep
- dupd set-world-handle
- win-hWnd show-window ;
-
-M: windows-ui-backend select-gl-context ( handle -- )
- [ win-hDC ] keep win-hRC wglMakeCurrent win32-error=0/f ;
-
-M: windows-ui-backend flush-gl-context ( handle -- )
- win-hDC SwapBuffers win32-error=0/f ;
-
-! Move window to front
-M: windows-ui-backend raise-window* ( world -- )
- world-handle [
- win-hWnd SetFocus drop
- ] when* ;
-
-M: windows-ui-backend set-title ( string world -- )
- world-handle
- dup win-title [ free ] when*
- >r utf16n malloc-string r>
- 2dup set-win-title
- win-hWnd WM_SETTEXT 0 roll alien-address SendMessage drop ;
-
-M: windows-ui-backend ui
- [
- [
- stop-after-last-window? on
- init-clipboard
- init-win32-ui
- start-ui
- event-loop
- ] [ cleanup-win32-ui ] [ ] cleanup
- ] ui-running ;
-
-M: windows-ui-backend beep ( -- )
- 0 MessageBeep drop ;
-
-windows-ui-backend ui-backend set-global
-
-[ "ui" ] main-vocab-hook set-global
+++ /dev/null
-Slava Pestov
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2005, 2008 Eduardo Cavazos and Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays ui ui.gadgets
-ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render
-assocs kernel math namespaces opengl sequences strings x11.xlib
-x11.events x11.xim x11.glx x11.clipboard x11.constants
-x11.windows io.encodings.string io.encodings.ascii
-io.encodings.utf8 combinators debugger command-line qualified
-math.vectors classes.tuple opengl.gl threads math.geometry.rect ;
-QUALIFIED: system
-IN: ui.x11
-
-SINGLETON: x11-ui-backend
-
-: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
-
-TUPLE: x11-handle window glx xic ;
-
-C: <x11-handle> x11-handle
-
-M: world expose-event nip relayout ;
-
-M: world configure-event
- over configured-loc over (>>window-loc)
- swap configured-dim over (>>dim)
- ! In case dimensions didn't change
- relayout-1 ;
-
-: modifiers
- {
- { S+ HEX: 1 }
- { C+ HEX: 4 }
- { A+ HEX: 8 }
- } ;
-
-: key-codes
- H{
- { HEX: FF08 "BACKSPACE" }
- { HEX: FF09 "TAB" }
- { HEX: FF0D "RET" }
- { HEX: FF8D "ENTER" }
- { HEX: FF1B "ESC" }
- { HEX: FFFF "DELETE" }
- { HEX: FF50 "HOME" }
- { HEX: FF51 "LEFT" }
- { HEX: FF52 "UP" }
- { HEX: FF53 "RIGHT" }
- { HEX: FF54 "DOWN" }
- { HEX: FF55 "PAGE_UP" }
- { HEX: FF56 "PAGE_DOWN" }
- { HEX: FF57 "END" }
- { HEX: FF58 "BEGIN" }
- { HEX: FFBE "F1" }
- { HEX: FFBF "F2" }
- { HEX: FFC0 "F3" }
- { HEX: FFC1 "F4" }
- { HEX: FFC2 "F5" }
- { HEX: FFC3 "F6" }
- { HEX: FFC4 "F7" }
- { HEX: FFC5 "F8" }
- { HEX: FFC6 "F9" }
- } ;
-
-: key-code ( keysym -- keycode action? )
- dup key-codes at [ t ] [ 1string f ] ?if ;
-
-: event-modifiers ( event -- seq )
- XKeyEvent-state modifiers modifier ;
-
-: key-down-event>gesture ( event world -- string gesture )
- dupd
- world-handle x11-handle-xic lookup-string
- >r swap event-modifiers r> key-code <key-down> ;
-
-M: world key-down-event
- [ key-down-event>gesture ] keep world-focus
- [ send-gesture ] keep swap [ user-input ] [ 2drop ] if ;
-
-: key-up-event>gesture ( event -- gesture )
- dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
-
-M: world key-up-event
- >r key-up-event>gesture r> world-focus send-gesture drop ;
-
-: mouse-event>gesture ( event -- modifiers button loc )
- dup event-modifiers over XButtonEvent-button
- rot mouse-event-loc ;
-
-M: world button-down-event
- >r mouse-event>gesture >r <button-down> r> r>
- send-button-down ;
-
-M: world button-up-event
- >r mouse-event>gesture >r <button-up> r> r>
- send-button-up ;
-
-: mouse-event>scroll-direction ( event -- pair )
- XButtonEvent-button {
- { 4 { 0 -1 } }
- { 5 { 0 1 } }
- { 6 { -1 0 } }
- { 7 { 1 0 } }
- } at ;
-
-M: world wheel-event
- >r dup mouse-event>scroll-direction swap mouse-event-loc r>
- send-wheel ;
-
-M: world enter-event motion-event ;
-
-M: world leave-event 2drop forget-rollover ;
-
-M: world motion-event
- >r dup XMotionEvent-x swap XMotionEvent-y 2array r>
- move-hand fire-motion ;
-
-M: world focus-in-event
- nip
- dup world-handle x11-handle-xic XSetICFocus focus-world ;
-
-M: world focus-out-event
- nip
- dup world-handle x11-handle-xic XUnsetICFocus unfocus-world ;
-
-M: world selection-notify-event
- [ world-handle x11-handle-window selection-from-event ] keep
- world-focus user-input ;
-
-: supported-type? ( atom -- ? )
- { "UTF8_STRING" "STRING" "TEXT" }
- [ x-atom = ] with contains? ;
-
-: clipboard-for-atom ( atom -- clipboard )
- {
- { [ dup XA_PRIMARY = ] [ drop selection get ] }
- { [ dup XA_CLIPBOARD = ] [ drop clipboard get ] }
- [ drop <clipboard> ]
- } cond ;
-
-: encode-clipboard ( string type -- bytes )
- XSelectionRequestEvent-target
- XA_UTF8_STRING = utf8 ascii ? encode ;
-
-: set-selection-prop ( evt -- )
- dpy get swap
- [ XSelectionRequestEvent-requestor ] keep
- [ XSelectionRequestEvent-property ] keep
- [ XSelectionRequestEvent-target ] keep
- >r 8 PropModeReplace r>
- [
- XSelectionRequestEvent-selection
- clipboard-for-atom x-clipboard-contents
- ] keep encode-clipboard dup length XChangeProperty drop ;
-
-M: world selection-request-event
- drop dup XSelectionRequestEvent-target {
- { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
- { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
- { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
- [ drop send-notify-failure ]
- } cond ;
-
-M: x11-ui-backend (close-window) ( handle -- )
- dup x11-handle-xic XDestroyIC
- dup x11-handle-glx destroy-glx
- x11-handle-window dup unregister-window
- destroy-window ;
-
-M: world client-event
- swap close-box? [ ungraft ] [ drop ] if ;
-
-: gadget-window ( world -- )
- dup window-loc>> over rect-dim glx-window
- over "Factor" create-xic <x11-handle>
- 2dup x11-handle-window register-window
- swap set-world-handle ;
-
-: wait-event ( -- event )
- QueuedAfterFlush events-queued 0 > [
- next-event dup
- None XFilterEvent zero? [ drop wait-event ] unless
- ] [
- ui-wait wait-event
- ] if ;
-
-M: x11-ui-backend do-events
- wait-event dup XAnyEvent-window window dup
- [ [ 2dup handle-event ] assert-depth ] when 2drop ;
-
-: x-clipboard@ ( gadget clipboard -- prop win )
- x-clipboard-atom swap
- find-world world-handle x11-handle-window ;
-
-M: x-clipboard copy-clipboard
- [ x-clipboard@ own-selection ] keep
- set-x-clipboard-contents ;
-
-M: x-clipboard paste-clipboard
- >r find-world world-handle x11-handle-window
- r> x-clipboard-atom convert-selection ;
-
-: init-clipboard ( -- )
- XA_PRIMARY <x-clipboard> selection set-global
- XA_CLIPBOARD <x-clipboard> clipboard set-global ;
-
-: set-title-old ( dpy window string -- )
- dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
-
-: set-title-new ( dpy window string -- )
- >r
- XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace
- r> utf8 encode dup length XChangeProperty drop ;
-
-M: x11-ui-backend set-title ( string world -- )
- world-handle x11-handle-window swap dpy get -rot
- 3dup set-title-old set-title-new ;
-
-M: x11-ui-backend set-fullscreen* ( ? world -- )
- world-handle x11-handle-window "XClientMessageEvent" <c-object>
- tuck set-XClientMessageEvent-window
- swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
- over set-XClientMessageEvent-data0
- ClientMessage over set-XClientMessageEvent-type
- dpy get over set-XClientMessageEvent-display
- "_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
- 32 over set-XClientMessageEvent-format
- "_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
- >r dpy get root get 0 SubstructureNotifyMask r> XSendEvent drop ;
-
-
-M: x11-ui-backend (open-window) ( world -- )
- dup gadget-window
- world-handle x11-handle-window dup set-closable map-window ;
-
-M: x11-ui-backend raise-window* ( world -- )
- world-handle [
- dpy get swap x11-handle-window XRaiseWindow drop
- ] when* ;
-
-M: x11-ui-backend select-gl-context ( handle -- )
- dpy get swap
- dup x11-handle-window swap x11-handle-glx glXMakeCurrent
- [ "Failed to set current GLX context" throw ] unless ;
-
-M: x11-ui-backend flush-gl-context ( handle -- )
- dpy get swap x11-handle-window glXSwapBuffers ;
-
-M: x11-ui-backend ui ( -- )
- [
- f [
- [
- stop-after-last-window? on
- init-clipboard
- start-ui
- event-loop
- ] with-xim
- ] with-x
- ] ui-running ;
-
-M: x11-ui-backend beep ( -- )
- dpy get 100 XBell drop ;
-
-x11-ui-backend ui-backend set-global
-
-[ "DISPLAY" system:os-env "ui" "listener" ? ]
-main-vocab-hook set-global
--- /dev/null
+IN: compiler.cfg.builder.tests
+USING: compiler.cfg.builder tools.test ;
+
+\ build-cfg must-infer
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel assocs sequences sequences.lib fry accessors
-compiler.cfg compiler.vops compiler.vops.builder
-namespaces math inference.dataflow optimizer.allot combinators
-math.order ;
+namespaces math combinators math.order
+compiler.tree
+compiler.tree.combinators
+compiler.tree.propagation.info
+compiler.cfg
+compiler.vops
+compiler.vops.builder ;
IN: compiler.cfg.builder
-! Convert dataflow IR to procedure CFG.
+! Convert tree SSA IR to CFG SSA IR.
+
! We construct the graph and set successors first, then we
! set predecessors in a separate pass. This simplifies the
! logic.
SYMBOL: procedures
-SYMBOL: values>vregs
-
SYMBOL: loop-nesting
-GENERIC: convert* ( node -- )
+SYMBOL: values>vregs
GENERIC: convert ( node -- )
+M: #introduce convert drop ;
+
: init-builder ( -- )
- H{ } clone values>vregs set
- V{ } clone loop-nesting set ;
+ H{ } clone values>vregs set ;
: end-basic-block ( -- )
basic-block get [ %b emit ] when ;
set-basic-block ;
: convert-nodes ( node -- )
- dup basic-block get and [
- [ convert ] [ successor>> convert-nodes ] bi
- ] [ drop ] if ;
+ [ convert ] each ;
: (build-cfg) ( node word -- )
init-builder
begin-basic-block
basic-block get swap procedures get set-at
- %prolog emit
convert-nodes ;
: build-cfg ( node word -- procedures )
2bi
] if ;
-: load-inputs ( node -- )
- [ in-d>> %data (load-inputs) ]
- [ in-r>> %retain (load-inputs) ]
- bi ;
+: load-in-d ( node -- ) in-d>> %data (load-inputs) ;
+
+: load-in-r ( node -- ) in-r>> %retain (load-inputs) ;
: (store-outputs) ( seq stack -- )
over empty? [ 2drop ] [
2bi
] if ;
-: store-outputs ( node -- )
- [ out-d>> %data (store-outputs) ]
- [ out-r>> %retain (store-outputs) ]
- bi ;
-
-M: #push convert*
- out-d>> [
- [ produce-vreg ] [ value-literal ] bi
- emit-literal
- ] each ;
+: store-out-d ( node -- ) out-d>> %data (store-outputs) ;
-M: #shuffle convert* drop ;
-
-M: #>r convert* drop ;
-
-M: #r> convert* drop ;
-
-M: node convert
- [ load-inputs ]
- [ convert* ]
- [ store-outputs ]
- tri ;
+: store-out-r ( node -- ) out-r>> %retain (store-outputs) ;
: (emit-call) ( word -- )
begin-basic-block %call emit begin-basic-block ;
: intrinsic-inputs ( node -- )
- [ load-inputs ]
+ [ load-in-d ]
[ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ]
bi ;
: intrinsic-outputs ( node -- )
[ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ]
- [ store-outputs ]
+ [ store-out-d ]
bi ;
: intrinsic ( node quot -- )
tri
] with-scope ; inline
-USING: kernel.private math.private slots.private
-optimizer.allot ;
+USING: kernel.private math.private slots.private ;
: maybe-emit-fixnum-shift-fast ( node -- node )
- dup dup in-d>> second node-literal? [
- dup dup in-d>> second node-literal
+ dup dup in-d>> second node-value-info literal>> dup fixnum? [
'[ , emit-fixnum-shift-fast ] intrinsic
] [
- dup param>> (emit-call)
+ drop dup word>> (emit-call)
] if ;
: emit-call ( node -- )
- dup param>> {
+ dup word>> {
{ \ tag [ [ emit-tag ] intrinsic ] }
{ \ slot [ [ dup emit-slot ] intrinsic ] }
{ \ float> [ [ emit-float> ] intrinsic ] }
{ \ float? [ [ emit-float= ] intrinsic ] }
- { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
- { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
- { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
+ ! { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
+ ! { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
+ ! { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
[ (emit-call) ]
} case drop ;
M: #call convert emit-call ;
-M: #call-label convert
- dup param>> loop-nesting get at [
- basic-block get successors>> push
- end-basic-block
- basic-block off
- drop
- ] [
- (emit-call)
- ] if* ;
+: emit-call-loop ( #recursive -- )
+ dup label>> loop-nesting get at basic-block get successors>> push
+ end-basic-block
+ basic-block off
+ drop ;
+
+: emit-call-recursive ( #recursive -- )
+ label>> id>> (emit-call) ;
+
+M: #call-recursive convert
+ dup label>> loop?>>
+ [ emit-call-loop ] [ emit-call-recursive ] if ;
+
+M: #push convert
+ [
+ [ out-d>> first produce-vreg ]
+ [ node-output-infos first literal>> ]
+ bi emit-literal
+ ]
+ [ store-out-d ] bi ;
+
+M: #shuffle convert [ load-in-d ] [ store-out-d ] bi ;
+
+M: #>r convert [ load-in-d ] [ store-out-r ] bi ;
+
+M: #r> convert [ load-in-r ] [ store-out-d ] bi ;
+
+M: #terminate convert drop ;
: integer-conditional ( in1 in2 cc -- )
[ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline
[ set-basic-block ]
bi ;
-: phi-inputs ( #if -- vregs-seq )
- children>>
- [ last-node ] map
- [ #values? ] filter
- [ in-d>> [ value>vreg ] map ] map ;
-
-: phi-outputs ( #if -- vregs )
- successor>> out-d>> [ produce-vreg ] map ;
-
-: emit-phi ( #if -- )
- [ phi-outputs ] [ phi-inputs ] bi %phi emit ;
-
M: #if convert
- {
- [ load-inputs ]
- [ emit-if ]
- [ convert-if-children ]
- [ emit-phi ]
- } cleave ;
+ [ load-in-d ] [ emit-if ] [ convert-if-children ] tri ;
-M: #values convert drop ;
+M: #dispatch convert
+ "Unimplemented" throw ;
-M: #merge convert drop ;
-
-M: #entry convert drop ;
+M: #phi convert drop ;
M: #declare convert drop ;
-M: #terminate convert drop ;
+M: #return convert drop %return emit ;
-M: #label convert
- #! Labels create a new procedure.
- [ [ param>> ] [ node-child ] bi (build-cfg) ] [ (emit-call) ] bi ;
+: convert-recursive ( #recursive -- )
+ [ [ label>> id>> ] [ child>> ] bi (build-cfg) ]
+ [ (emit-call) ]
+ bi ;
-M: #loop convert
- #! Loops become part of the current CFG.
- begin-basic-block
- [ param>> basic-block get 2array loop-nesting get push ]
- [ node-child convert-nodes ]
- bi
+: begin-loop ( #recursive -- )
+ label>> basic-block get 2array loop-nesting get push ;
+
+: end-loop ( -- )
loop-nesting get pop* ;
-M: #return convert
- param>> loop-nesting get key? [
- %epilog emit
- %return emit
- ] unless ;
+: convert-loop ( #recursive -- )
+ begin-basic-block
+ [ begin-loop ]
+ [ child>> convert-nodes ]
+ [ drop end-loop ]
+ tri ;
+
+M: #recursive convert
+ dup label>> loop?>>
+ [ convert-loop ] [ convert-recursive ] if ;
+
+M: #copy convert drop ;
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.syntax help.markup math kernel
+words strings alien ;
+IN: compiler.generator.fixup
+
+HELP: frame-required
+{ $values { "n" "a non-negative integer" } }
+{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
+
+HELP: add-literal
+{ $values { "obj" object } { "n" integer } }
+{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
+
+HELP: rel-dlsym
+{ $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
+{ $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."
+} ;
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays byte-arrays generic assocs hashtables io.binary
+kernel kernel.private math namespaces sequences words
+quotations strings alien.accessors alien.strings layouts system
+combinators math.bitfields words.private cpu.architecture
+math.order accessors growable ;
+IN: compiler.generator.fixup
+
+: no-stack-frame -1 ; inline
+
+TUPLE: frame-required n ;
+
+: frame-required ( n -- ) \ frame-required boa , ;
+
+: stack-frame-size ( code -- n )
+ no-stack-frame [
+ dup frame-required? [ frame-required-n max ] [ drop ] if
+ ] reduce ;
+
+GENERIC: fixup* ( frame-size obj -- frame-size )
+
+: code-format 22 getenv ;
+
+: compiled-offset ( -- n ) building get length code-format * ;
+
+TUPLE: label offset ;
+
+: <label> ( -- label ) label new ;
+
+M: label fixup*
+ compiled-offset swap set-label-offset ;
+
+: define-label ( name -- ) <label> swap set ;
+
+: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
+
+: if-stack-frame ( frame-size quot -- )
+ swap dup no-stack-frame =
+ [ 2drop ] [ stack-frame swap call ] if ; inline
+
+M: word fixup*
+ {
+ { \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
+ { \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
+ } case ;
+
+SYMBOL: relocation-table
+SYMBOL: label-table
+
+! Relocation classes
+: rc-absolute-cell 0 ;
+: rc-absolute 1 ;
+: rc-relative 2 ;
+: rc-absolute-ppc-2/2 3 ;
+: rc-relative-ppc-2 4 ;
+: rc-relative-ppc-3 5 ;
+: rc-relative-arm-3 6 ;
+: rc-indirect-arm 7 ;
+: rc-indirect-arm-pc 8 ;
+
+: rc-absolute? ( n -- ? )
+ dup rc-absolute-cell =
+ over rc-absolute =
+ rot rc-absolute-ppc-2/2 = or or ;
+
+! Relocation types
+: rt-primitive 0 ;
+: rt-dlsym 1 ;
+: rt-literal 2 ;
+: rt-dispatch 3 ;
+: rt-xt 4 ;
+: rt-here 5 ;
+: rt-label 6 ;
+: rt-immediate 7 ;
+
+TUPLE: label-fixup label class ;
+
+: label-fixup ( label class -- ) \ label-fixup boa , ;
+
+M: label-fixup fixup*
+ dup class>> rc-absolute?
+ [ "Absolute labels not supported" throw ] when
+ dup label>> swap class>> compiled-offset 4 - rot
+ 3array label-table get push ;
+
+TUPLE: rel-fixup arg class type ;
+
+: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
+
+: push-4 ( value vector -- )
+ [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
+ swap set-alien-unsigned-4 ;
+
+M: rel-fixup fixup*
+ [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
+ [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
+ [ relocation-table get push-4 ] bi@ ;
+
+M: frame-required fixup* drop ;
+
+M: integer fixup* , ;
+
+: adjoin* ( obj table -- n )
+ 2dup swap [ eq? ] curry find drop
+ [ 2nip ] [ dup length >r push r> ] if* ;
+
+SYMBOL: literal-table
+
+: add-literal ( obj -- n ) literal-table get adjoin* ;
+
+: add-dlsym-literals ( symbol dll -- )
+ >r string>symbol r> 2array literal-table get push-all ;
+
+: rel-dlsym ( name dll class -- )
+ >r literal-table get length >r
+ add-dlsym-literals
+ r> r> rt-dlsym rel-fixup ;
+
+: rel-word ( word class -- )
+ >r add-literal r> rt-xt rel-fixup ;
+
+: rel-primitive ( word class -- )
+ >r def>> first r> rt-primitive rel-fixup ;
+
+: rel-literal ( literal class -- )
+ >r add-literal r> rt-literal rel-fixup ;
+
+: rel-this ( class -- )
+ 0 swap rt-label rel-fixup ;
+
+: rel-here ( class -- )
+ 0 swap rt-here rel-fixup ;
+
+: init-fixup ( -- )
+ BV{ } clone relocation-table set
+ V{ } clone label-table set ;
+
+: resolve-labels ( labels -- labels' )
+ [
+ first3 label-offset
+ [ "Unresolved label" throw ] unless*
+ 3array
+ ] map concat ;
+
+: fixup ( code -- literals relocation labels code )
+ [
+ init-fixup
+ dup stack-frame-size swap [ fixup* ] each drop
+
+ literal-table get >array
+ relocation-table get >byte-array
+ label-table get resolve-labels
+ ] { } make ;
--- /dev/null
+Support for generation of relocatable code
--- /dev/null
+USING: help.markup help.syntax words debugger generator.fixup
+generator.registers quotations kernel vectors arrays effects
+sequences ;
+IN: compiler.generator
+
+ARTICLE: "generator" "Compiled code generator"
+"Most of the words in the " { $vocab-link "generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
+$nl
+"Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":"
+{ $subsection compiled-stack-traces? }
+"Assembler intrinsics can be defined for low-level optimization:"
+{ $subsection define-intrinsic }
+{ $subsection define-intrinsics }
+{ $subsection define-if-intrinsic }
+{ $subsection define-if-intrinsics }
+"The main entry point into the code generator:"
+{ $subsection generate } ;
+
+ABOUT: "generator"
+
+HELP: compiled
+{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
+
+HELP: compiling-word
+{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ;
+
+HELP: compiling-label
+{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ;
+
+HELP: compiled-stack-traces?
+{ $values { "?" "a boolean" } }
+{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
+
+HELP: literal-table
+{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;
+
+HELP: begin-compiling
+{ $values { "word" word } { "label" word } }
+{ $description "Prepares to generate machine code for a word." } ;
+
+HELP: with-generator
+{ $values { "node" "a dataflow node" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
+{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the dataflow node." } ;
+
+HELP: generate-node
+{ $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
+{ $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." }
+{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
+
+HELP: generate-nodes
+{ $values { "node" "a dataflow node" } }
+{ $description "Recursively generate machine code for a dataflow graph." }
+{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
+
+HELP: generate
+{ $values { "word" word } { "label" word } { "node" "a dataflow node" } }
+{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
+
+HELP: define-intrinsics
+{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot assoc }" } " pairs" } }
+{ $description "Defines a set of assembly intrinsics for the word. When a call to the word is being compiled, each intrinsic is tested in turn; the first applicable one will be called to generate machine code. If no suitable intrinsic is found, a simple call to the word is compiled instead."
+$nl
+"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
+
+HELP: define-intrinsic
+{ $values { "word" word } { "quot" quotation } { "assoc" "an assoc" } }
+{ $description "Defines an assembly intrinsic for the word. When a call to the word is being compiled, this intrinsic will be used if it is found to be applicable. If it is not applicable, a simple call to the word is compiled instead."
+$nl
+"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
+
+HELP: if>boolean-intrinsic
+{ $values { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } }
+{ $description "Generates code which pushes " { $link t } " or " { $link f } " on the data stack, depending on whether the quotation jumps to the label or not." } ;
+
+HELP: define-if-intrinsics
+{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot inputs }" } " pairs" } }
+{ $description "Defines a set of conditional assembly intrinsics for the word, which must have a boolean value as its single output."
+$nl
+"The quotations must have stack effect " { $snippet "( label -- )" } "; they are required to branch to the label if the word evaluates to true."
+$nl
+"The " { $snippet "inputs" } " are in the same format as the " { $link +input+ } " key to " { $link with-template } "; a description can be found in the documentation for thatt word." }
+{ $notes "Conditional intrinsics are used when the word is followed by a call to " { $link if } ". They allow for tighter code to be generated in certain situations; for example, if two integers are being compared and the result is immediately used to branch, the intermediate boolean does not need to be pushed at all." } ;
+
+HELP: define-if-intrinsic
+{ $values { "word" word } { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } { "inputs" "a sequence of input register specifiers" } }
+{ $description "Defines a conditional assembly intrinsic for the word, which must have a boolean value as its single output."
+$nl
+"See " { $link define-if-intrinsics } " for a description of the parameters." } ;
--- /dev/null
+ ! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes combinators
+cpu.architecture effects generic hashtables io kernel
+kernel.private layouts math math.parser namespaces prettyprint
+quotations sequences system threads words vectors sets dequeues
+cursors continuations.private summary alien alien.c-types
+alien.structs alien.strings alien.arrays libc compiler.errors
+stack-checker.inlining
+compiler.tree compiler.tree.builder compiler.tree.combinators
+compiler.tree.propagation.info compiler.generator.fixup
+compiler.generator.registers compiler.generator.iterator ;
+IN: compiler.generator
+
+SYMBOL: compile-queue
+SYMBOL: compiled
+
+: queue-compile ( word -- )
+ {
+ { [ dup "forgotten" word-prop ] [ ] }
+ { [ dup compiled get key? ] [ ] }
+ { [ dup inlined-block? ] [ ] }
+ { [ dup primitive? ] [ ] }
+ [ dup compile-queue get push-front ]
+ } cond drop ;
+
+: maybe-compile ( word -- )
+ dup compiled>> [ drop ] [ queue-compile ] if ;
+
+SYMBOL: compiling-word
+
+SYMBOL: compiling-label
+
+SYMBOL: compiling-loops
+
+! Label of current word, after prologue, makes recursion faster
+SYMBOL: current-label-start
+
+: compiled-stack-traces? ( -- ? ) 59 getenv ;
+
+: begin-compiling ( word label -- )
+ H{ } clone compiling-loops set
+ compiling-label set
+ compiling-word set
+ compiled-stack-traces?
+ compiling-word get f ?
+ 1vector literal-table set
+ f compiling-label get compiled get set-at ;
+
+: save-machine-code ( literals relocation labels code -- )
+ 4array compiling-label get compiled get set-at ;
+
+: with-generator ( nodes word label quot -- )
+ [
+ >r begin-compiling r>
+ { } make fixup
+ save-machine-code
+ ] with-scope ; inline
+
+GENERIC: generate-node ( node -- next )
+
+: generate-nodes ( nodes -- )
+ [ current-node generate-node ] iterate-nodes end-basic-block ;
+
+: init-generate-nodes ( -- )
+ init-templates
+ %save-word-xt
+ %prologue-later
+ current-label-start define-label
+ current-label-start resolve-label ;
+
+: generate ( nodes word label -- )
+ [
+ init-generate-nodes
+ [ generate-nodes ] with-node-iterator
+ ] with-generator ;
+
+: intrinsics ( #call -- quot )
+ word>> "intrinsics" word-prop ;
+
+: if-intrinsics ( #call -- quot )
+ word>> "if-intrinsics" word-prop ;
+
+! node
+M: node generate-node drop iterate-next ;
+
+: %jump ( word -- )
+ dup compiling-label get eq?
+ [ drop current-label-start get ] [ %epilogue-later ] if
+ %jump-label ;
+
+: generate-call ( label -- next )
+ dup maybe-compile
+ end-basic-block
+ dup compiling-loops get at [
+ %jump-label f
+ ] [
+ tail-call? [
+ %jump f
+ ] [
+ 0 frame-required
+ %call
+ iterate-next
+ ] if
+ ] ?if ;
+
+! #recursive
+: compile-recursive ( node -- )
+ dup label>> id>> generate-call >r
+ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
+ r> ;
+
+: compiling-loop ( word -- )
+ <label> dup resolve-label swap compiling-loops get set-at ;
+
+: compile-loop ( node -- )
+ end-basic-block
+ [ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi
+ iterate-next ;
+
+M: #recursive generate-node
+ dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
+
+! #if
+: end-false-branch ( label -- )
+ tail-call? [ %return drop ] [ %jump-label ] if ;
+
+: generate-branch ( nodes -- )
+ [ copy-templates generate-nodes ] with-scope ;
+
+: generate-if ( node label -- next )
+ <label> [
+ >r >r children>> first2 swap generate-branch
+ r> r> end-false-branch resolve-label
+ generate-branch
+ init-templates
+ ] keep resolve-label iterate-next ;
+
+M: #if generate-node
+ [ <label> dup %jump-f ]
+ H{ { +input+ { { f "flag" } } } }
+ with-template
+ generate-if ;
+
+! #dispatch
+: dispatch-branch ( nodes word -- label )
+ gensym [
+ [
+ copy-templates
+ %save-dispatch-xt
+ %prologue-later
+ [ generate-nodes ] with-node-iterator
+ ] with-generator
+ ] keep ;
+
+: dispatch-branches ( node -- )
+ children>> [
+ compiling-word get dispatch-branch
+ %dispatch-label
+ ] each ;
+
+: generate-dispatch ( node -- )
+ %dispatch dispatch-branches init-templates ;
+
+M: #dispatch generate-node
+ #! The order here is important, dispatch-branches must
+ #! run after %dispatch, so that each branch gets the
+ #! correct register state
+ tail-call? [
+ generate-dispatch iterate-next
+ ] [
+ compiling-word get gensym [
+ [
+ init-generate-nodes
+ generate-dispatch
+ ] with-generator
+ ] keep generate-call
+ ] if ;
+
+! #call
+: define-intrinsics ( word intrinsics -- )
+ "intrinsics" set-word-prop ;
+
+: define-intrinsic ( word quot assoc -- )
+ 2array 1array define-intrinsics ;
+
+: define-if>branch-intrinsics ( word intrinsics -- )
+ "if-intrinsics" set-word-prop ;
+
+: if>boolean-intrinsic ( quot -- )
+ "false" define-label
+ "end" define-label
+ "false" get swap call
+ t "if-scratch" get load-literal
+ "end" get %jump-label
+ "false" resolve-label
+ f "if-scratch" get load-literal
+ "end" resolve-label
+ "if-scratch" get phantom-push ; inline
+
+: define-if>boolean-intrinsics ( word intrinsics -- )
+ [
+ >r [ if>boolean-intrinsic ] curry r>
+ { { f "if-scratch" } } +scratch+ associate assoc-union
+ ] assoc-map "intrinsics" set-word-prop ;
+
+: define-if-intrinsics ( word intrinsics -- )
+ [ +input+ associate ] assoc-map
+ 2dup define-if>branch-intrinsics
+ define-if>boolean-intrinsics ;
+
+: define-if-intrinsic ( word quot inputs -- )
+ 2array 1array define-if-intrinsics ;
+
+: do-if-intrinsic ( pair -- next )
+ <label> [
+ swap do-template
+ node> next dup >node
+ ] keep generate-if ;
+
+: find-intrinsic ( #call -- pair/f )
+ intrinsics find-template ;
+
+: find-if-intrinsic ( #call -- pair/f )
+ node@ next #if? [
+ if-intrinsics find-template
+ ] [
+ drop f
+ ] if ;
+
+M: #call generate-node
+ dup node-input-infos [ class>> ] map set-operand-classes
+ dup find-if-intrinsic [
+ do-if-intrinsic
+ ] [
+ dup find-intrinsic [
+ do-template iterate-next
+ ] [
+ word>> generate-call
+ ] ?if
+ ] ?if ;
+
+! #call-recursive
+M: #call-recursive generate-node label>> id>> generate-call ;
+
+! #push
+M: #push generate-node
+ literal>> <constant> phantom-push iterate-next ;
+
+! #shuffle
+M: #shuffle generate-node
+ shuffle-effect phantom-shuffle iterate-next ;
+
+M: #>r generate-node
+ in-d>> length
+ phantom->r
+ iterate-next ;
+
+M: #r> generate-node
+ out-d>> length
+ phantom-r>
+ iterate-next ;
+
+! #return
+M: #return generate-node
+ drop end-basic-block %return f ;
+
+M: #return-recursive generate-node
+ end-basic-block
+ label>> id>> compiling-loops get key?
+ [ %return ] unless f ;
+
+! #alien-invoke
+: large-struct? ( ctype -- ? )
+ dup c-struct? [
+ heap-size struct-small-enough? not
+ ] [ drop f ] if ;
+
+: alien-parameters ( params -- seq )
+ dup parameters>>
+ swap return>> large-struct? [ "void*" prefix ] when ;
+
+: alien-return ( params -- ctype )
+ return>> dup large-struct? [ drop "void" ] when ;
+
+: c-type-stack-align ( type -- align )
+ dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
+
+: parameter-align ( n type -- n delta )
+ over >r c-type-stack-align align dup r> - ;
+
+: parameter-sizes ( types -- total offsets )
+ #! Compute stack frame locations.
+ [
+ 0 [
+ [ parameter-align drop dup , ] keep stack-size +
+ ] reduce cell align
+ ] { } make ;
+
+: return-size ( ctype -- n )
+ #! Amount of space we reserve for a return value.
+ dup large-struct? [ heap-size ] [ drop 0 ] if ;
+
+: alien-stack-frame ( params -- n )
+ alien-parameters parameter-sizes drop ;
+
+: alien-invoke-frame ( params -- n )
+ #! One cell is temporary storage, temp@
+ dup return>> return-size
+ swap alien-stack-frame +
+ cell + ;
+
+: set-stack-frame ( n -- )
+ dup [ frame-required ] when* \ stack-frame set ;
+
+: with-stack-frame ( n quot -- )
+ swap set-stack-frame
+ call
+ f set-stack-frame ; inline
+
+GENERIC: reg-size ( register-class -- n )
+
+M: int-regs reg-size drop cell ;
+
+M: single-float-regs reg-size drop 4 ;
+
+M: double-float-regs reg-size drop 8 ;
+
+GENERIC: reg-class-variable ( register-class -- symbol )
+
+M: reg-class reg-class-variable ;
+
+M: float-regs reg-class-variable drop float-regs ;
+
+GENERIC: inc-reg-class ( register-class -- )
+
+M: reg-class inc-reg-class
+ dup reg-class-variable inc
+ fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
+
+M: float-regs inc-reg-class
+ dup call-next-method
+ fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
+
+: reg-class-full? ( class -- ? )
+ [ reg-class-variable get ] [ param-regs length ] bi >= ;
+
+: spill-param ( reg-class -- n reg-class )
+ stack-params get
+ >r reg-size stack-params +@ r>
+ stack-params ;
+
+: fastcall-param ( reg-class -- n reg-class )
+ [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
+
+: alloc-parameter ( parameter -- reg reg-class )
+ c-type-reg-class dup reg-class-full?
+ [ spill-param ] [ fastcall-param ] if
+ [ param-reg ] keep ;
+
+: (flatten-int-type) ( size -- )
+ cell /i "void*" c-type <repetition> % ;
+
+GENERIC: flatten-value-type ( type -- )
+
+M: object flatten-value-type , ;
+
+M: struct-type flatten-value-type ( type -- )
+ stack-size cell align (flatten-int-type) ;
+
+M: long-long-type flatten-value-type ( type -- )
+ stack-size cell align (flatten-int-type) ;
+
+: flatten-value-types ( params -- params )
+ #! Convert value type structs to consecutive void*s.
+ [
+ 0 [
+ c-type
+ [ parameter-align (flatten-int-type) ] keep
+ [ stack-size cell align + ] keep
+ flatten-value-type
+ ] reduce drop
+ ] { } make ;
+
+: each-parameter ( parameters quot -- )
+ >r [ parameter-sizes nip ] keep r> 2each ; inline
+
+: reverse-each-parameter ( parameters quot -- )
+ >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
+
+: reset-freg-counts ( -- )
+ { int-regs float-regs stack-params } [ 0 swap set ] each ;
+
+: with-param-regs ( quot -- )
+ #! In quot you can call alloc-parameter
+ [ reset-freg-counts call ] with-scope ; inline
+
+: move-parameters ( node word -- )
+ #! Moves values from C stack to registers (if word is
+ #! %load-param-reg) and registers to C stack (if word is
+ #! %save-param-reg).
+ >r
+ alien-parameters
+ flatten-value-types
+ r> [ >r alloc-parameter r> execute ] curry each-parameter ;
+ inline
+
+: unbox-parameters ( offset node -- )
+ parameters>> [
+ %prepare-unbox >r over + r> unbox-parameter
+ ] reverse-each-parameter drop ;
+
+: prepare-box-struct ( node -- offset )
+ #! Return offset on C stack where to store unboxed
+ #! parameters. If the C function is returning a structure,
+ #! the first parameter is an implicit target area pointer,
+ #! so we need to use a different offset.
+ return>> dup large-struct?
+ [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
+
+: objects>registers ( params -- )
+ #! Generate code for unboxing a list of C types, then
+ #! generate code for moving these parameters to register on
+ #! architectures where parameters are passed in registers.
+ [
+ [ prepare-box-struct ] keep
+ [ unbox-parameters ] keep
+ \ %load-param-reg move-parameters
+ ] with-param-regs ;
+
+: box-return* ( node -- )
+ return>> [ ] [ box-return ] if-void ;
+
+TUPLE: no-such-library name ;
+
+M: no-such-library summary
+ drop "Library not found" ;
+
+M: no-such-library compiler-error-type
+ drop +linkage+ ;
+
+: no-such-library ( name -- )
+ \ no-such-library boa
+ compiling-word get compiler-error ;
+
+TUPLE: no-such-symbol name ;
+
+M: no-such-symbol summary
+ drop "Symbol not found" ;
+
+M: no-such-symbol compiler-error-type
+ drop +linkage+ ;
+
+: no-such-symbol ( name -- )
+ \ no-such-symbol boa
+ compiling-word get compiler-error ;
+
+: check-dlsym ( symbols dll -- )
+ dup dll-valid? [
+ dupd [ dlsym ] curry contains?
+ [ drop ] [ no-such-symbol ] if
+ ] [
+ dll-path no-such-library drop
+ ] if ;
+
+: stdcall-mangle ( symbol node -- symbol )
+ "@"
+ swap parameters>> parameter-sizes drop
+ number>string 3append ;
+
+: alien-invoke-dlsym ( params -- symbols dll )
+ dup function>> dup pick stdcall-mangle 2array
+ swap library>> library dup [ dll>> ] when
+ 2dup check-dlsym ;
+
+M: #alien-invoke generate-node
+ params>>
+ dup alien-invoke-frame [
+ end-basic-block
+ %prepare-alien-invoke
+ dup objects>registers
+ %prepare-var-args
+ dup alien-invoke-dlsym %alien-invoke
+ dup %cleanup
+ box-return*
+ iterate-next
+ ] with-stack-frame ;
+
+! #alien-indirect
+M: #alien-indirect generate-node
+ params>>
+ dup alien-invoke-frame [
+ ! Flush registers
+ end-basic-block
+ ! Save registers for GC
+ %prepare-alien-invoke
+ ! Save alien at top of stack to temporary storage
+ %prepare-alien-indirect
+ dup objects>registers
+ %prepare-var-args
+ ! Call alien in temporary storage
+ %alien-indirect
+ dup %cleanup
+ box-return*
+ iterate-next
+ ] with-stack-frame ;
+
+! #alien-callback
+: box-parameters ( params -- )
+ alien-parameters [ box-parameter ] each-parameter ;
+
+: registers>objects ( node -- )
+ [
+ dup \ %save-param-reg move-parameters
+ "nest_stacks" f %alien-invoke
+ box-parameters
+ ] with-param-regs ;
+
+TUPLE: callback-context ;
+
+: current-callback 2 getenv ;
+
+: wait-to-return ( token -- )
+ dup current-callback eq? [
+ drop
+ ] [
+ yield wait-to-return
+ ] if ;
+
+: do-callback ( quot token -- )
+ init-catchstack
+ dup 2 setenv
+ slip
+ wait-to-return ; inline
+
+: callback-return-quot ( ctype -- quot )
+ return>> {
+ { [ dup "void" = ] [ drop [ ] ] }
+ { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
+ [ c-type c-type-unboxer-quot ]
+ } cond ;
+
+: callback-prep-quot ( params -- quot )
+ parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
+
+: wrap-callback-quot ( params -- quot )
+ [
+ [ callback-prep-quot ]
+ [ quot>> ]
+ [ callback-return-quot ] tri 3append ,
+ [ callback-context new do-callback ] %
+ ] [ ] make ;
+
+: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
+
+: callback-unwind ( params -- n )
+ {
+ { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
+ { [ dup return>> large-struct? ] [ drop 4 ] }
+ [ drop 0 ]
+ } cond ;
+
+: %callback-return ( params -- )
+ #! All the extra book-keeping for %unwind is only for x86.
+ #! On other platforms its an alias for %return.
+ dup alien-return
+ [ %unnest-stacks ] [ %callback-value ] if-void
+ callback-unwind %unwind ;
+
+: generate-callback ( params -- )
+ dup xt>> dup [
+ init-templates
+ %prologue-later
+ dup alien-stack-frame [
+ [ registers>objects ]
+ [ wrap-callback-quot %alien-callback ]
+ [ %callback-return ]
+ tri
+ ] with-stack-frame
+ ] with-generator ;
+
+M: #alien-callback generate-node
+ end-basic-block
+ params>> generate-callback iterate-next ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces sequences cursors kernel compiler.tree ;
+IN: compiler.generator.iterator
+
+SYMBOL: node-stack
+
+: >node ( cursor -- ) node-stack get push ;
+: node> ( -- cursor ) node-stack get pop ;
+: node@ ( -- cursor ) node-stack get peek ;
+: current-node ( -- node ) node@ value ;
+
+: iterate-next ( -- cursor ) node@ next ;
+
+: iterate-nodes ( cursor quot: ( -- ) -- )
+ over [
+ [ swap >node call node> drop ] keep iterate-nodes
+ ] [
+ 2drop
+ ] if ; inline recursive
+
+: with-node-iterator ( quot -- )
+ >r V{ } clone node-stack r> with-variable ; inline
+
+DEFER: (tail-call?)
+
+: tail-phi? ( cursor -- ? )
+ [ value #phi? ] [ next (tail-call?) ] bi and ;
+
+: (tail-call?) ( cursor -- ? )
+ [ value [ #return? ] [ #terminate? ] bi or ]
+ [ tail-phi? ]
+ bi or ;
+
+: tail-call? ( -- ? )
+ node-stack get [
+ next
+ [ (tail-call?) ]
+ [ value #terminate? not ]
+ bi and
+ ] all? ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs classes classes.private classes.algebra
+combinators cpu.architecture generator.fixup hashtables kernel
+layouts math namespaces quotations sequences system vectors
+words effects alien byte-arrays
+accessors sets math.order ;
+IN: compiler.generator.registers
+
+SYMBOL: +input+
+SYMBOL: +output+
+SYMBOL: +scratch+
+SYMBOL: +clobber+
+SYMBOL: known-tag
+
+<PRIVATE
+
+! Value protocol
+GENERIC: set-operand-class ( class obj -- )
+GENERIC: operand-class* ( operand -- class )
+GENERIC: move-spec ( obj -- spec )
+GENERIC: live-vregs* ( obj -- )
+GENERIC: live-loc? ( actual current -- ? )
+GENERIC# (lazy-load) 1 ( value spec -- value )
+GENERIC: lazy-store ( dst src -- )
+GENERIC: minimal-ds-loc* ( min obj -- min )
+
+! This will be a multimethod soon
+DEFER: %move
+
+MIXIN: value
+
+PRIVATE>
+
+: operand-class ( operand -- class )
+ operand-class* object or ;
+
+! Default implementation
+M: value set-operand-class 2drop ;
+M: value operand-class* drop f ;
+M: value live-vregs* drop ;
+M: value live-loc? 2drop f ;
+M: value minimal-ds-loc* drop ;
+M: value lazy-store 2drop ;
+
+! A scratch register for computations
+TUPLE: vreg n reg-class ;
+
+C: <vreg> vreg ( n reg-class -- vreg )
+
+M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
+M: vreg live-vregs* , ;
+M: vreg move-spec reg-class>> move-spec ;
+
+INSTANCE: vreg value
+
+M: float-regs move-spec drop float ;
+M: float-regs operand-class* drop float ;
+
+! Temporary register for stack shuffling
+SINGLETON: temp-reg
+
+M: temp-reg move-spec drop f ;
+
+INSTANCE: temp-reg value
+
+! A data stack location.
+TUPLE: ds-loc n class ;
+
+: <ds-loc> ( n -- loc ) f ds-loc boa ;
+
+M: ds-loc minimal-ds-loc* ds-loc-n min ;
+M: ds-loc operand-class* ds-loc-class ;
+M: ds-loc set-operand-class set-ds-loc-class ;
+M: ds-loc live-loc?
+ over ds-loc? [ [ ds-loc-n ] bi@ = not ] [ 2drop t ] if ;
+
+! A retain stack location.
+TUPLE: rs-loc n class ;
+
+: <rs-loc> ( n -- loc ) f rs-loc boa ;
+M: rs-loc operand-class* rs-loc-class ;
+M: rs-loc set-operand-class set-rs-loc-class ;
+M: rs-loc live-loc?
+ over rs-loc? [ [ rs-loc-n ] bi@ = not ] [ 2drop t ] if ;
+
+UNION: loc ds-loc rs-loc ;
+
+M: loc move-spec drop loc ;
+
+INSTANCE: loc value
+
+M: f move-spec drop loc ;
+M: f operand-class* ;
+
+! A stack location which has been loaded into a register. To
+! read the location, we just read the register, but when time
+! comes to save it back to the stack, we know the register just
+! contains a stack value so we don't have to redundantly write
+! it back.
+TUPLE: cached loc vreg ;
+
+C: <cached> cached
+
+M: cached set-operand-class cached-vreg set-operand-class ;
+M: cached operand-class* cached-vreg operand-class* ;
+M: cached move-spec drop cached ;
+M: cached live-vregs* cached-vreg live-vregs* ;
+M: cached live-loc? cached-loc live-loc? ;
+M: cached (lazy-load) >r cached-vreg r> (lazy-load) ;
+M: cached lazy-store
+ 2dup cached-loc live-loc?
+ [ "live-locs" get at %move ] [ 2drop ] if ;
+M: cached minimal-ds-loc* cached-loc minimal-ds-loc* ;
+
+INSTANCE: cached value
+
+! A tagged pointer
+TUPLE: tagged vreg class ;
+
+: <tagged> ( vreg -- tagged )
+ f tagged boa ;
+
+M: tagged v>operand tagged-vreg v>operand ;
+M: tagged set-operand-class set-tagged-class ;
+M: tagged operand-class* tagged-class ;
+M: tagged move-spec drop f ;
+M: tagged live-vregs* tagged-vreg , ;
+
+INSTANCE: tagged value
+
+! Unboxed alien pointers
+TUPLE: unboxed-alien vreg ;
+C: <unboxed-alien> unboxed-alien
+M: unboxed-alien v>operand unboxed-alien-vreg v>operand ;
+M: unboxed-alien operand-class* drop simple-alien ;
+M: unboxed-alien move-spec class ;
+M: unboxed-alien live-vregs* unboxed-alien-vreg , ;
+
+INSTANCE: unboxed-alien value
+
+TUPLE: unboxed-byte-array vreg ;
+C: <unboxed-byte-array> unboxed-byte-array
+M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ;
+M: unboxed-byte-array operand-class* drop c-ptr ;
+M: unboxed-byte-array move-spec class ;
+M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ;
+
+INSTANCE: unboxed-byte-array value
+
+TUPLE: unboxed-f vreg ;
+C: <unboxed-f> unboxed-f
+M: unboxed-f v>operand unboxed-f-vreg v>operand ;
+M: unboxed-f operand-class* drop \ f ;
+M: unboxed-f move-spec class ;
+M: unboxed-f live-vregs* unboxed-f-vreg , ;
+
+INSTANCE: unboxed-f value
+
+TUPLE: unboxed-c-ptr vreg ;
+C: <unboxed-c-ptr> unboxed-c-ptr
+M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ;
+M: unboxed-c-ptr operand-class* drop c-ptr ;
+M: unboxed-c-ptr move-spec class ;
+M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ;
+
+INSTANCE: unboxed-c-ptr value
+
+! A constant value
+TUPLE: constant value ;
+C: <constant> constant
+M: constant operand-class* constant-value class ;
+M: constant move-spec class ;
+
+INSTANCE: constant value
+
+<PRIVATE
+
+! Moving values between locations and registers
+: %move-bug ( -- * ) "Bug in generator.registers" throw ;
+
+: %unbox-c-ptr ( dst src -- )
+ dup operand-class {
+ { [ dup \ f class<= ] [ drop %unbox-f ] }
+ { [ dup simple-alien class<= ] [ drop %unbox-alien ] }
+ { [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
+ [ drop %unbox-any-c-ptr ]
+ } cond ; inline
+
+: %move-via-temp ( dst src -- )
+ #! For many transfers, such as loc to unboxed-alien, we
+ #! don't have an intrinsic, so we transfer the source to
+ #! temp then temp to the destination.
+ temp-reg over %move
+ operand-class temp-reg
+ tagged new
+ swap >>vreg
+ swap >>class
+ %move ;
+
+: %move ( dst src -- )
+ 2dup [ move-spec ] bi@ 2array {
+ { { f f } [ %move-bug ] }
+ { { f unboxed-c-ptr } [ %move-bug ] }
+ { { f unboxed-byte-array } [ %move-bug ] }
+
+ { { f constant } [ constant-value swap load-literal ] }
+
+ { { f float } [ %box-float ] }
+ { { f unboxed-alien } [ %box-alien ] }
+ { { f loc } [ %peek ] }
+
+ { { float f } [ %unbox-float ] }
+ { { unboxed-alien f } [ %unbox-alien ] }
+ { { unboxed-byte-array f } [ %unbox-byte-array ] }
+ { { unboxed-f f } [ %unbox-f ] }
+ { { unboxed-c-ptr f } [ %unbox-c-ptr ] }
+ { { loc f } [ swap %replace ] }
+
+ [ drop %move-via-temp ]
+ } case ;
+
+! A compile-time stack
+TUPLE: phantom-stack height stack ;
+
+M: phantom-stack clone
+ call-next-method [ clone ] change-stack ;
+
+GENERIC: finalize-height ( stack -- )
+
+: new-phantom-stack ( class -- stack )
+ >r 0 V{ } clone r> boa ; inline
+
+: (loc) ( m stack -- n )
+ #! Utility for methods on <loc>
+ height>> - ;
+
+: (finalize-height) ( stack word -- )
+ #! We consolidate multiple stack height changes until the
+ #! last moment, and we emit the final height changing
+ #! instruction here.
+ [
+ over zero? [ 2drop ] [ execute ] if 0
+ ] curry change-height drop ; inline
+
+GENERIC: <loc> ( n stack -- loc )
+
+TUPLE: phantom-datastack < phantom-stack ;
+
+: <phantom-datastack> ( -- stack )
+ phantom-datastack new-phantom-stack ;
+
+M: phantom-datastack <loc> (loc) <ds-loc> ;
+
+M: phantom-datastack finalize-height
+ \ %inc-d (finalize-height) ;
+
+TUPLE: phantom-retainstack < phantom-stack ;
+
+: <phantom-retainstack> ( -- stack )
+ phantom-retainstack new-phantom-stack ;
+
+M: phantom-retainstack <loc> (loc) <rs-loc> ;
+
+M: phantom-retainstack finalize-height
+ \ %inc-r (finalize-height) ;
+
+: phantom-locs ( n phantom -- locs )
+ #! A sequence of n ds-locs or rs-locs indexing the stack.
+ >r <reversed> r> [ <loc> ] curry map ;
+
+: phantom-locs* ( phantom -- locs )
+ [ stack>> length ] keep phantom-locs ;
+
+: phantoms ( -- phantom phantom )
+ phantom-datastack get phantom-retainstack get ;
+
+: (each-loc) ( phantom quot -- )
+ >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
+
+: each-loc ( quot -- )
+ phantoms 2array swap [ (each-loc) ] curry each ; inline
+
+: adjust-phantom ( n phantom -- )
+ swap [ + ] curry change-height drop ;
+
+: cut-phantom ( n phantom -- seq )
+ swap [ cut* swap ] curry change-stack drop ;
+
+: phantom-append ( seq stack -- )
+ over length over adjust-phantom stack>> push-all ;
+
+: add-locs ( n phantom -- )
+ 2dup stack>> length <= [
+ 2drop
+ ] [
+ [ phantom-locs ] keep
+ [ stack>> length head-slice* ] keep
+ [ append >vector ] change-stack drop
+ ] if ;
+
+: phantom-input ( n phantom -- seq )
+ 2dup add-locs
+ 2dup cut-phantom
+ >r >r neg r> adjust-phantom r> ;
+
+: each-phantom ( quot -- ) phantoms rot bi@ ; inline
+
+: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
+
+: live-vregs ( -- seq )
+ [ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
+
+: (live-locs) ( phantom -- seq )
+ #! Discard locs which haven't moved
+ [ phantom-locs* ] [ stack>> ] bi zip
+ [ live-loc? ] assoc-filter
+ values ;
+
+: live-locs ( -- seq )
+ [ (live-locs) ] each-phantom append prune ;
+
+! Operands holding pointers to freshly-allocated objects which
+! are guaranteed to be in the nursery
+SYMBOL: fresh-objects
+
+! Computing free registers and initializing allocator
+: reg-spec>class ( spec -- class )
+ float eq? double-float-regs int-regs ? ;
+
+: free-vregs ( reg-class -- seq )
+ #! Free vregs in a given register class
+ \ free-vregs get at ;
+
+: alloc-vreg ( spec -- reg )
+ [ reg-spec>class free-vregs pop ] keep {
+ { f [ <tagged> ] }
+ { unboxed-alien [ <unboxed-alien> ] }
+ { unboxed-byte-array [ <unboxed-byte-array> ] }
+ { unboxed-f [ <unboxed-f> ] }
+ { unboxed-c-ptr [ <unboxed-c-ptr> ] }
+ [ drop ]
+ } case ;
+
+: compatible? ( value spec -- ? )
+ >r move-spec r> {
+ { [ 2dup = ] [ t ] }
+ { [ dup unboxed-c-ptr eq? ] [
+ over { unboxed-byte-array unboxed-alien } member?
+ ] }
+ [ f ]
+ } cond 2nip ;
+
+: allocation ( value spec -- reg-class )
+ {
+ { [ dup quotation? ] [ 2drop f ] }
+ { [ 2dup compatible? ] [ 2drop f ] }
+ [ nip reg-spec>class ]
+ } cond ;
+
+: alloc-vreg-for ( value spec -- vreg )
+ alloc-vreg swap operand-class
+ over tagged? [ >>class ] [ drop ] if ;
+
+M: value (lazy-load)
+ 2dup allocation [
+ dupd alloc-vreg-for dup rot %move
+ ] [
+ drop
+ ] if ;
+
+: (compute-free-vregs) ( used class -- vector )
+ #! Find all vregs in 'class' which are not in 'used'.
+ [ vregs length reverse ] keep
+ [ <vreg> ] curry map swap diff
+ >vector ;
+
+: compute-free-vregs ( -- )
+ #! Create a new hashtable for thee free-vregs variable.
+ live-vregs
+ { int-regs double-float-regs }
+ [ 2dup (compute-free-vregs) ] H{ } map>assoc
+ \ free-vregs set
+ drop ;
+
+M: loc lazy-store
+ 2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
+
+: do-shuffle ( hash -- )
+ dup assoc-empty? [
+ drop
+ ] [
+ "live-locs" set
+ [ lazy-store ] each-loc
+ ] if ;
+
+: fast-shuffle ( locs -- )
+ #! We have enough free registers to load all shuffle inputs
+ #! at once
+ [ dup f (lazy-load) ] H{ } map>assoc do-shuffle ;
+
+: minimal-ds-loc ( phantom -- n )
+ #! When shuffling more values than can fit in registers, we
+ #! need to find an area on the data stack which isn't in
+ #! use.
+ [ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
+
+: find-tmp-loc ( -- n )
+ #! Find an area of the data stack which is not referenced
+ #! from the phantom stacks. We can clobber there all we want
+ [ minimal-ds-loc ] each-phantom min 1- ;
+
+: slow-shuffle-mapping ( locs tmp -- pairs )
+ >r dup length r>
+ [ swap - <ds-loc> ] curry map zip ;
+
+: slow-shuffle ( locs -- )
+ #! We don't have enough free registers to load all shuffle
+ #! inputs, so we use a single temporary register, together
+ #! with the area of the data stack above the stack pointer
+ find-tmp-loc slow-shuffle-mapping [
+ [
+ swap dup cached? [ cached-vreg ] when %move
+ ] assoc-each
+ ] keep >hashtable do-shuffle ;
+
+: fast-shuffle? ( live-locs -- ? )
+ #! Test if we have enough free registers to load all
+ #! shuffle inputs at once.
+ int-regs free-vregs [ length ] bi@ <= ;
+
+: finalize-locs ( -- )
+ #! Perform any deferred stack shuffling.
+ [
+ \ free-vregs [ [ clone ] assoc-map ] change
+ live-locs dup fast-shuffle?
+ [ fast-shuffle ] [ slow-shuffle ] if
+ ] with-scope ;
+
+: finalize-vregs ( -- )
+ #! Store any vregs to their final stack locations.
+ [
+ dup loc? over cached? or [ 2drop ] [ %move ] if
+ ] each-loc ;
+
+: reset-phantom ( phantom -- )
+ #! Kill register assignments but preserve constants and
+ #! class information.
+ dup phantom-locs*
+ over stack>> [
+ dup constant? [ nip ] [
+ operand-class over set-operand-class
+ ] if
+ ] 2map
+ over stack>> delete-all
+ swap stack>> push-all ;
+
+: reset-phantoms ( -- )
+ [ reset-phantom ] each-phantom ;
+
+: finalize-contents ( -- )
+ finalize-locs finalize-vregs reset-phantoms ;
+
+! Loading stacks to vregs
+: free-vregs? ( int# float# -- ? )
+ double-float-regs free-vregs length <=
+ >r int-regs free-vregs length <= r> and ;
+
+: phantom&spec ( phantom spec -- phantom' spec' )
+ >r stack>> r>
+ [ length f pad-left ] keep
+ [ <reversed> ] bi@ ; inline
+
+: phantom&spec-agree? ( phantom spec quot -- ? )
+ >r phantom&spec r> 2all? ; inline
+
+: vreg-substitution ( value vreg -- pair )
+ dupd <cached> 2array ;
+
+: substitute-vreg? ( old new -- ? )
+ #! We don't substitute locs for float or alien vregs,
+ #! since in those cases the boxing overhead might kill us.
+ cached-vreg tagged? >r loc? r> and ;
+
+: substitute-vregs ( values vregs -- )
+ [ vreg-substitution ] 2map
+ [ substitute-vreg? ] assoc-filter >hashtable
+ [ >r stack>> r> substitute-here ] curry each-phantom ;
+
+: set-operand ( value var -- )
+ >r dup constant? [ constant-value ] when r> set ;
+
+: lazy-load ( values template -- )
+ #! Set operand vars here.
+ 2dup [ first (lazy-load) ] 2map
+ dup rot [ second set-operand ] 2each
+ substitute-vregs ;
+
+: load-inputs ( -- )
+ +input+ get
+ [ length phantom-datastack get phantom-input ] keep
+ lazy-load ;
+
+: output-vregs ( -- seq seq )
+ +output+ +clobber+ [ get [ get ] map ] bi@ ;
+
+: clash? ( seq -- ? )
+ phantoms [ stack>> ] bi@ append [
+ dup cached? [ cached-vreg ] when swap member?
+ ] with contains? ;
+
+: outputs-clash? ( -- ? )
+ output-vregs append clash? ;
+
+: count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ;
+
+: count-input-vregs ( phantom spec -- )
+ phantom&spec [
+ >r dup cached? [ cached-vreg ] when r> first allocation
+ ] 2map count-vregs ;
+
+: count-scratch-regs ( spec -- )
+ [ first reg-spec>class ] map count-vregs ;
+
+: guess-vregs ( dinput rinput scratch -- int# float# )
+ [
+ 0 int-regs set
+ 0 double-float-regs set
+ count-scratch-regs
+ phantom-retainstack get swap count-input-vregs
+ phantom-datastack get swap count-input-vregs
+ int-regs get double-float-regs get
+ ] with-scope ;
+
+: alloc-scratch ( -- )
+ +scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
+
+: guess-template-vregs ( -- int# float# )
+ +input+ get { } +scratch+ get guess-vregs ;
+
+: template-inputs ( -- )
+ ! Load input values into registers
+ load-inputs
+ ! Allocate scratch registers
+ alloc-scratch
+ ! If outputs clash, we write values back to the stack
+ outputs-clash? [ finalize-contents ] when ;
+
+: template-outputs ( -- )
+ +output+ get [ get ] map phantom-datastack get phantom-append ;
+
+: value-matches? ( value spec -- ? )
+ #! If the spec is a quotation and the value is a literal
+ #! fixnum, see if the quotation yields true when applied
+ #! to the fixnum. Otherwise, the values don't match. If the
+ #! spec is not a quotation, its a reg-class, in which case
+ #! the value is always good.
+ dup quotation? [
+ over constant?
+ [ >r constant-value r> call ] [ 2drop f ] if
+ ] [
+ 2drop t
+ ] if ;
+
+: class-matches? ( actual expected -- ? )
+ {
+ { f [ drop t ] }
+ { known-tag [ dup [ class-tag >boolean ] when ] }
+ [ class<= ]
+ } case ;
+
+: spec-matches? ( value spec -- ? )
+ 2dup first value-matches?
+ >r >r operand-class 2 r> ?nth class-matches? r> and ;
+
+: template-matches? ( spec -- ? )
+ phantom-datastack get +input+ rot at
+ [ spec-matches? ] phantom&spec-agree? ;
+
+: ensure-template-vregs ( -- )
+ guess-template-vregs free-vregs? [
+ finalize-contents compute-free-vregs
+ ] unless ;
+
+: clear-phantoms ( -- )
+ [ stack>> delete-all ] each-phantom ;
+
+PRIVATE>
+
+: set-operand-classes ( classes -- )
+ phantom-datastack get
+ over length over add-locs
+ stack>> [ set-operand-class ] 2reverse-each ;
+
+: end-basic-block ( -- )
+ #! Commit all deferred stacking shuffling, and ensure the
+ #! in-memory data and retain stacks are up to date with
+ #! respect to the compiler's current picture.
+ finalize-contents
+ clear-phantoms
+ finalize-heights
+ fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
+
+: with-template ( quot hash -- )
+ clone [
+ ensure-template-vregs
+ template-inputs call template-outputs
+ ] bind
+ compute-free-vregs ; inline
+
+: do-template ( pair -- )
+ #! Use with return value from find-template
+ first2 with-template ;
+
+: fresh-object ( obj -- ) fresh-objects get push ;
+
+: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
+
+: init-templates ( -- )
+ #! Initialize register allocator.
+ V{ } clone fresh-objects set
+ <phantom-datastack> phantom-datastack set
+ <phantom-retainstack> phantom-retainstack set
+ compute-free-vregs ;
+
+: copy-templates ( -- )
+ #! Copies register allocator state, used when compiling
+ #! branches.
+ fresh-objects [ clone ] change
+ phantom-datastack [ clone ] change
+ phantom-retainstack [ clone ] change
+ compute-free-vregs ;
+
+: find-template ( templates -- pair/f )
+ #! Pair has shape { quot hash }
+ [ second template-matches? ] find nip ;
+
+: operand-tag ( operand -- tag/f )
+ operand-class dup [ class-tag ] when ;
+
+UNION: immediate fixnum POSTPONE: f ;
+
+: operand-immediate? ( operand -- ? )
+ operand-class immediate class<= ;
+
+: phantom-push ( obj -- )
+ 1 phantom-datastack get adjust-phantom
+ phantom-datastack get stack>> push ;
+
+: phantom-shuffle ( shuffle -- )
+ [ effect-in length phantom-datastack get phantom-input ] keep
+ shuffle* phantom-datastack get phantom-append ;
+
+: phantom->r ( n -- )
+ phantom-datastack get phantom-input
+ phantom-retainstack get phantom-append ;
+
+: phantom-r> ( n -- )
+ phantom-retainstack get phantom-input
+ phantom-datastack get phantom-append ;
--- /dev/null
+Register allocation and intrinsic selection
--- /dev/null
+Final stage of compilation generates machine code from dataflow IR
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces sequences assocs io
-prettyprint inference generator optimizer compiler.vops
-compiler.cfg.builder compiler.cfg.simplifier
-compiler.machine.builder compiler.machine.simplifier ;
-IN: compiler.machine.debug
-
-: dataflow>linear ( dataflow word -- linear )
- [
- init-counter
- build-cfg
- [ simplify-cfg build-mr simplify-mr ] assoc-map
- ] with-scope ;
-
-: linear. ( linear -- )
- [
- "==== " write swap .
- [ . ] each
- ] assoc-each ;
-
-: linearized-quot. ( quot -- )
- dataflow optimize
- "Anonymous quotation" dataflow>linear
- linear. ;
-
-: linearized-word. ( word -- )
- dup word-dataflow nip optimize swap dataflow>linear linear. ;
-
-: >basic-block ( quot -- basic-block )
- dataflow optimize
- [
- init-counter
- "Anonymous quotation" build-cfg
- >alist first second simplify-cfg
- ] with-scope ;
-
-: basic-block. ( basic-block -- )
- instructions>> [ . ] each ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces sequences assocs io
+prettyprint inference generator optimizer
+compiler.vops
+compiler.tree.builder
+compiler.tree.optimizer
+compiler.cfg.builder
+compiler.cfg.simplifier
+compiler.machine.builder
+compiler.machine.simplifier ;
+IN: compiler.machine.debugger
+
+: tree>linear ( tree word -- linear )
+ [
+ init-counter
+ build-cfg
+ [ simplify-cfg build-mr simplify-mr ] assoc-map
+ ] with-scope ;
+
+: linear. ( linear -- )
+ [
+ "==== " write swap .
+ [ . ] each
+ ] assoc-each ;
+
+: linearized-quot. ( quot -- )
+ build-tree optimize-tree
+ "Anonymous quotation" tree>linear
+ linear. ;
+
+: linearized-word. ( word -- )
+ dup build-tree-from-word nip optimize-tree
+ dup word-dataflow nip optimize swap tree>linear linear. ;
+
+: >basic-block ( quot -- basic-block )
+ build-tree optimize-tree
+ [
+ init-counter
+ "Anonymous quotation" build-cfg
+ >alist first second simplify-cfg
+ ] with-scope ;
+
+: basic-block. ( basic-block -- )
+ instructions>> [ . ] each ;
] with-tree-builder nip
unclip-last in-d>> ;
+: build-sub-tree ( #call quot -- nodes )
+ [ [ out-d>> ] [ in-d>> ] bi ] dip
+ build-tree-with
+ rot #copy suffix ;
+
: (make-specializer) ( class picker -- quot )
swap "predicate" word-prop append ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel sets namespaces accessors assocs
+arrays combinators continuations
+compiler.tree
+compiler.tree.def-use
+compiler.tree.combinators ;
+IN: compiler.tree.checker
+
+! Check some invariants.
+ERROR: check-use-error value message ;
+
+: check-use ( value uses -- )
+ [ empty? [ "No use" check-use-error ] [ drop ] if ]
+ [ all-unique? [ drop ] [ "Uses not all unique" check-use-error ] if ] 2bi ;
+
+: check-def-use ( -- )
+ def-use get [ uses>> check-use ] assoc-each ;
+
+GENERIC: check-node ( node -- )
+
+M: #shuffle check-node
+ [ [ mapping>> values ] [ in-d>> ] bi subset? [ "Bad mapping inputs" throw ] unless ]
+ [ [ mapping>> keys ] [ out-d>> ] bi set= [ "Bad mapping outputs" throw ] unless ]
+ bi ;
+
+: check-lengths ( seq -- )
+ [ length ] map all-equal? [ "Bad lengths" throw ] unless ;
+
+M: #copy check-node inputs/outputs 2array check-lengths ;
+
+M: #>r check-node inputs/outputs 2array check-lengths ;
+
+M: #r> check-node inputs/outputs 2array check-lengths ;
+
+M: #return-recursive check-node inputs/outputs 2array check-lengths ;
+
+M: #phi check-node
+ {
+ [ [ phi-in-d>> ] [ out-d>> ] bi 2array check-lengths ]
+ [ [ phi-in-r>> ] [ out-r>> ] bi 2array check-lengths ]
+ [ phi-in-d>> check-lengths ]
+ [ phi-in-r>> check-lengths ]
+ } cleave ;
+
+M: #enter-recursive check-node
+ [ [ in-d>> ] [ out-d>> ] bi 2array check-lengths ]
+ [ [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix check-lengths ]
+ bi ;
+
+M: #push check-node
+ out-d>> length 1 = [ "Bad #push" throw ] unless ;
+
+M: node check-node drop ;
+
+ERROR: check-node-error node error ;
+
+: check-nodes ( nodes -- )
+ compute-def-use
+ check-def-use
+ [ [ check-node ] [ check-node-error ] recover ] each-node ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sequences.deep combinators fry
classes.algebra namespaces assocs math math.private
-math.partial-dispatch
+math.partial-dispatch classes.tuple classes.tuple.private
compiler.tree
+compiler.tree.intrinsics
compiler.tree.combinators
compiler.tree.propagation.info
compiler.tree.propagation.branches ;
: remove-overflow-check ( #call -- #call )
[ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
+: immutable-tuple-boa? ( #call -- ? )
+ dup word>> \ <tuple-boa> eq? [
+ dup in-d>> peek node-value-info
+ literal>> class>> immutable-tuple-class?
+ ] [ drop f ] if ;
+
+: immutable-tuple-boa ( #call -- #call )
+ \ <immutable-tuple-boa> >>word ;
+
M: #call cleanup*
{
{ [ dup body>> ] [ cleanup-inlining ] }
{ [ dup cleanup-folding? ] [ cleanup-folding ] }
{ [ dup remove-overflow-check? ] [ remove-overflow-check ] }
+ { [ dup immutable-tuple-boa? ] [ immutable-tuple-boa ] }
[ ]
} cond ;
M: #branch cleanup*
{
- [ live-branches>> live-branches set ]
[ delete-unreachable-branches ]
[ cleanup-children ]
[ fold-only-branch ]
+ [ live-branches>> live-branches set ]
} cleave ;
: cleanup-phi-in ( phi-in live-branches -- phi-in' )
[ '[ , cleanup-phi-in ] change-phi-in-r ]
[ '[ , cleanup-phi-in ] change-phi-info-d ]
[ '[ , cleanup-phi-in ] change-phi-info-r ]
- } cleave ;
+ } cleave
+ live-branches off ;
: >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi #copy ;
+++ /dev/null
-IN: compiler.tree.copy-equiv.tests
-USING: compiler.tree.copy-equiv tools.test namespaces kernel
-assocs ;
-
-H{ } clone copies set
-
-[ ] [ 0 introduce-value ] unit-test
-[ ] [ 1 introduce-value ] unit-test
-[ ] [ 1 2 is-copy-of ] unit-test
-[ ] [ 2 3 is-copy-of ] unit-test
-[ ] [ 2 4 is-copy-of ] unit-test
-[ ] [ 4 5 is-copy-of ] unit-test
-[ ] [ 0 6 is-copy-of ] unit-test
-
-[ 0 ] [ 0 resolve-copy ] unit-test
-[ 1 ] [ 5 resolve-copy ] unit-test
-
-! Make sure that we did path compression
-[ 1 ] [ 5 copies get at ] unit-test
-
-[ 1 ] [ 1 resolve-copy ] unit-test
-[ 1 ] [ 2 resolve-copy ] unit-test
-[ 1 ] [ 3 resolve-copy ] unit-test
-[ 1 ] [ 4 resolve-copy ] unit-test
-[ 0 ] [ 6 resolve-copy ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences assocs math kernel accessors fry
-combinators sets locals
-compiler.tree
-compiler.tree.def-use
-compiler.tree.combinators ;
-IN: compiler.tree.copy-equiv
-
-! This is not really a compiler pass; its invoked as part of
-! propagation.
-
-! Two values are copy-equivalent if they are always identical
-! at run-time ("DS" relation). This is just a weak form of
-! value numbering.
-
-! Mapping from values to their canonical leader
-SYMBOL: copies
-
-:: compress-path ( source assoc -- destination )
- [let | destination [ source assoc at ] |
- source destination = [ source ] [
- [let | destination' [ destination assoc compress-path ] |
- destination' destination = [
- destination' source assoc set-at
- ] unless
- destination'
- ]
- ] if
- ] ;
-
-: resolve-copy ( copy -- val ) copies get compress-path ;
-
-: is-copy-of ( val copy -- ) copies get set-at ;
-
-: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
-
-: introduce-value ( val -- ) copies get conjoin ;
-
-GENERIC: compute-copy-equiv* ( node -- )
-
-M: #shuffle compute-copy-equiv*
- [ out-d>> dup ] [ mapping>> ] bi
- '[ , at ] map swap are-copies-of ;
-
-M: #>r compute-copy-equiv*
- [ in-d>> ] [ out-r>> ] bi are-copies-of ;
-
-M: #r> compute-copy-equiv*
- [ in-r>> ] [ out-d>> ] bi are-copies-of ;
-
-M: #copy compute-copy-equiv*
- [ in-d>> ] [ out-d>> ] bi are-copies-of ;
-
-M: #return-recursive compute-copy-equiv*
- [ in-d>> ] [ out-d>> ] bi are-copies-of ;
-
-: compute-phi-equiv ( inputs outputs -- )
- #! An output is a copy of every input if all inputs are
- #! copies of the same original value.
- [
- swap sift [ resolve-copy ] map
- dup [ all-equal? ] [ empty? not ] bi and
- [ first swap is-copy-of ] [ 2drop ] if
- ] 2each ;
-
-M: #phi compute-copy-equiv*
- [ [ phi-in-d>> ] [ out-d>> ] bi compute-phi-equiv ]
- [ [ phi-in-r>> ] [ out-r>> ] bi compute-phi-equiv ] bi ;
-
-M: node compute-copy-equiv* drop ;
-
-: compute-copy-equiv ( node -- )
- [ node-defs-values [ introduce-value ] each ]
- [ compute-copy-equiv* ]
- bi ;
[ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
2bi ;
+M: #alien-invoke backward
+ nip [ look-at-inputs ] [ look-at-outputs ] bi ;
+
+M: #alien-indirect backward
+ nip [ look-at-inputs ] [ look-at-outputs ] bi ;
+
M: node backward 2drop ;
: backward-dfa ( node quot -- assoc ) [ backward ] dfa ; inline
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors namespaces assocs dequeues search-dequeues
-kernel sequences words sets stack-checker.inlining compiler.tree
-compiler.tree.def-use compiler.tree.combinators ;
+kernel sequences words sets
+stack-checker.branches stack-checker.inlining
+compiler.tree compiler.tree.def-use compiler.tree.combinators ;
IN: compiler.tree.dataflow-analysis
! Dataflow analysis
: dfa ( node mark-quot iterate-quot -- assoc )
init-dfa
[ each-node ] dip
- work-list get H{ { f f } } clone
+ work-list get H{ { +bottom+ f } } clone
[ rot '[ , , iterate-dfa ] slurp-dequeue ] keep ; inline
USING: namespaces assocs sequences compiler.tree.builder
compiler.tree.dead-code compiler.tree.def-use compiler.tree
compiler.tree.combinators tools.test kernel math
-stack-checker.state accessors ;
+stack-checker.state accessors combinators ;
IN: compiler.tree.dead-code.tests
\ remove-dead-code must-infer
build-tree
compute-def-use
remove-dead-code
- compute-def-use
- 0 swap [ dup #push? [ out-d>> length + ] [ drop ] if ] each-node ;
+ 0 swap [
+ {
+ { [ dup #push? ] [ out-d>> length + ] }
+ { [ dup #introduce? ] [ drop 1 + ] }
+ [ drop ]
+ } cond
+ ] each-node ;
[ 3 ] [ [ 1 2 3 ] count-live-values ] unit-test
+[ 1 ] [ [ drop ] count-live-values ] unit-test
+
[ 0 ] [ [ 1 drop ] count-live-values ] unit-test
[ 1 ] [ [ 1 2 drop ] count-live-values ] unit-test
-[ 2 ] [ [ [ 1 ] [ 2 ] if ] count-live-values ] unit-test
+[ 3 ] [ [ [ 1 ] [ 2 ] if ] count-live-values ] unit-test
-[ 0 ] [ [ [ 1 ] [ 2 ] if drop ] count-live-values ] unit-test
+[ 1 ] [ [ [ 1 ] [ 2 ] if drop ] count-live-values ] unit-test
-[ 0 ] [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test
+[ 2 ] [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test
[ 2 ] [ [ 1 2 + ] count-live-values ] unit-test
[ 0 ] [ [ 1 2 + 3 + drop ] count-live-values ] unit-test
-[ 3 ] [ [ [ 1 ] [ 2 ] if 3 + ] count-live-values ] unit-test
+[ 4 ] [ [ [ 1 ] [ 2 ] if 3 + ] count-live-values ] unit-test
-[ 0 ] [ [ [ 1 ] [ 2 ] if 3 + drop ] count-live-values ] unit-test
+[ 1 ] [ [ [ 1 ] [ 2 ] if 3 + drop ] count-live-values ] unit-test
[ 0 ] [ [ [ ] call ] count-live-values ] unit-test
USING: fry accessors namespaces assocs dequeues search-dequeues
kernel sequences words sets stack-checker.inlining
compiler.tree
+compiler.tree.combinators
compiler.tree.dataflow-analysis
-compiler.tree.dataflow-analysis.backward
-compiler.tree.combinators ;
+compiler.tree.dataflow-analysis.backward ;
IN: compiler.tree.dead-code
! Dead code elimination: remove #push and flushable #call whose
! outputs are unused using backward DFA.
GENERIC: mark-live-values ( node -- )
+M: #introduce mark-live-values
+ value>> look-at-value ;
+
M: #if mark-live-values look-at-inputs ;
M: #dispatch mark-live-values look-at-inputs ;
dup word>> "flushable" word-prop
[ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
+M: #alien-invoke mark-live-values
+ [ look-at-inputs ] [ look-at-outputs ] bi ;
+
+M: #alien-indirect mark-live-values
+ [ look-at-inputs ] [ look-at-outputs ] bi ;
+
M: #return mark-live-values
look-at-inputs ;
GENERIC: remove-dead-values* ( node -- )
-M: #introduce remove-dead-values*
- [ [ live-value? ] filter ] change-values drop ;
-
M: #>r remove-dead-values*
dup out-r>> first live-value? [ { } >>out-r ] unless
dup in-d>> first live-value? [ { } >>in-d ] unless
: filter-live ( values -- values' )
[ live-value? ] filter ;
+M: #call remove-dead-values*
+ [ filter-live ] change-in-d
+ [ filter-live ] change-out-d
+ drop ;
+
+M: #recursive remove-dead-values*
+ [ filter-live ] change-in-d
+ drop ;
+
+M: #call-recursive remove-dead-values*
+ [ filter-live ] change-in-d
+ [ filter-live ] change-out-d
+ drop ;
+
+M: #enter-recursive remove-dead-values*
+ [ filter-live ] change-in-d
+ [ filter-live ] change-out-d
+ drop ;
+
+M: #return-recursive remove-dead-values*
+ [ filter-live ] change-in-d
+ [ filter-live ] change-out-d
+ drop ;
+
M: #shuffle remove-dead-values*
[ filter-live ] change-in-d
[ filter-live ] change-out-d
M: node remove-dead-values* drop ;
-M: f remove-dead-values* drop ;
+: remove-dead-values ( nodes -- )
+ [ remove-dead-values* ] each-node ;
-GENERIC: remove-dead-nodes* ( node -- newnode/t )
+GENERIC: remove-dead-nodes* ( node -- node/f )
-: prune-if-empty ( node seq -- successor/t )
- empty? [ successor>> ] [ drop t ] if ; inline
+: prune-if-empty ( node seq -- node/f )
+ empty? [ drop f ] when ; inline
-M: #introduce remove-dead-nodes* dup values>> prune-if-empty ;
-
-: live-call? ( #call -- ? )
- out-d>> [ live-value? ] contains? ;
+: live-call? ( #call -- ? ) out-d>> [ live-value? ] contains? ;
M: #declare remove-dead-nodes* dup declaration>> prune-if-empty ;
-M: #call remove-dead-nodes*
- dup live-call? [ drop t ] [
- [ in-d>> #drop ] [ successor>> ] bi >>successor
- ] if ;
+M: #call remove-dead-nodes* dup live-call? [ in-d>> #drop ] unless ;
M: #shuffle remove-dead-nodes* dup in-d>> prune-if-empty ;
M: #copy remove-dead-nodes* dup in-d>> prune-if-empty ;
-: (remove-dead-code) ( node -- newnode )
- [
- dup remove-dead-values*
- dup remove-dead-nodes* dup t eq?
- [ drop ] [ nip (remove-dead-code) ] if
- ] transform-nodes ;
-
-M: #if remove-dead-nodes*
- [ (remove-dead-code) ] map-children t ;
-
-M: #dispatch remove-dead-nodes*
- [ (remove-dead-code) ] map-children t ;
-
-M: #recursive remove-dead-nodes*
- [ (remove-dead-code) ] change-child drop t ;
-
-M: node remove-dead-nodes* drop t ;
+M: node remove-dead-nodes* ;
-M: f remove-dead-nodes* drop t ;
+: remove-dead-nodes ( nodes -- nodes' )
+ [ remove-dead-nodes* ] map-nodes ;
: remove-dead-code ( node -- newnode )
- [ [ compute-live-values ] [ (remove-dead-code) ] bi ] with-scope ;
+ [ compute-live-values ]
+ [ remove-dead-values ]
+ [ remove-dead-nodes ]
+ tri ;
--- /dev/null
+IN: compiler.tree.debugger.tests
+USING: compiler.tree.debugger tools.test ;
+
+\ optimized. must-infer
+\ optimizer-report. must-infer
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel assocs fry match accessors namespaces effects
+sequences sequences.private quotations generic macros arrays
+prettyprint prettyprint.backend prettyprint.sections math words
+combinators io sorting
+compiler.tree
+compiler.tree.builder
+compiler.tree.optimizer
+compiler.tree.combinators
+compiler.tree.propagation.info ;
+IN: compiler.tree.debugger
+
+! A simple tool for turning tree IR into quotations and
+! printing reports, for debugging purposes.
+
+GENERIC: node>quot ( node -- )
+
+MACRO: match-choose ( alist -- )
+ [ '[ , ] ] assoc-map '[ , match-cond ] ;
+
+MATCH-VARS: ?a ?b ?c ;
+
+: pretty-shuffle ( effect -- word/f )
+ [ in>> ] [ out>> ] bi 2array {
+ { { { } { } } [ ] }
+ { { { ?a } { ?a } } [ ] }
+ { { { ?a ?b } { ?a ?b } } [ ] }
+ { { { ?a ?b ?c } { ?a ?b ?c } } [ ] }
+ { { { ?a } { } } [ drop ] }
+ { { { ?a ?b } { } } [ 2drop ] }
+ { { { ?a ?b ?c } { } } [ 3drop ] }
+ { { { ?a } { ?a ?a } } [ dup ] }
+ { { { ?a ?b } { ?a ?b ?a ?b } } [ 2dup ] }
+ { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] }
+ { { { ?a ?b } { ?a ?b ?a } } [ over ] }
+ { { { ?b ?a } { ?a ?b } } [ swap ] }
+ { { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] }
+ { { { ?a ?b } { ?a ?a ?b } } [ dupd ] }
+ { { { ?a ?b } { ?b ?a ?b } } [ tuck ] }
+ { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
+ { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
+ { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
+ { { { ?a ?b } { ?b } } [ nip ] }
+ { { { ?a ?b ?c } { ?c } } [ 2nip ] }
+ { _ f }
+ } match-choose ;
+
+TUPLE: shuffle effect ;
+
+M: shuffle pprint* effect>> effect>string text ;
+
+M: #shuffle node>quot
+ shuffle-effect dup pretty-shuffle
+ [ % ] [ shuffle boa , ] ?if ;
+
+: pushed-literals ( node -- seq )
+ dup out-d>> [ node-value-info literal>> literalize ] with map ;
+
+M: #push node>quot pushed-literals % ;
+
+M: #call node>quot word>> , ;
+
+M: #call-recursive node>quot label>> id>> , ;
+
+DEFER: nodes>quot
+
+DEFER: label
+
+M: #recursive node>quot
+ [ label>> id>> literalize , ]
+ [ child>> nodes>quot , \ label , ]
+ bi ;
+
+M: #if node>quot
+ children>> [ nodes>quot ] map % \ if , ;
+
+M: #dispatch node>quot
+ children>> [ nodes>quot ] map , \ dispatch , ;
+
+M: #>r node>quot in-d>> length \ >r <repetition> % ;
+
+M: #r> node>quot out-d>> length \ r> <repetition> % ;
+
+M: node node>quot drop ;
+
+: nodes>quot ( node -- quot )
+ [ [ node>quot ] each ] [ ] make ;
+
+: optimized. ( quot/word -- )
+ dup word? [ specialized-def ] when
+ build-tree optimize-tree nodes>quot . ;
+
+SYMBOL: words-called
+SYMBOL: generics-called
+SYMBOL: methods-called
+SYMBOL: intrinsics-called
+SYMBOL: node-count
+
+: make-report ( word/quot -- assoc )
+ [
+ dup word? [ build-tree-from-word nip ] [ build-tree ] if
+ optimize-tree
+
+ H{ } clone words-called set
+ H{ } clone generics-called set
+ H{ } clone methods-called set
+ H{ } clone intrinsics-called set
+
+ 0 swap [
+ >r 1+ r>
+ dup #call? [
+ word>> {
+ { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
+ { [ dup generic? ] [ generics-called ] }
+ { [ dup method-body? ] [ methods-called ] }
+ [ words-called ]
+ } cond 1 -rot get at+
+ ] [ drop ] if
+ ] each-node
+ node-count set
+ ] H{ } make-assoc ;
+
+: report. ( report -- )
+ [
+ "==== Total number of IR nodes:" print
+ node-count get .
+
+ {
+ { generics-called "==== Generic word calls:" }
+ { words-called "==== Ordinary word calls:" }
+ { methods-called "==== Non-inlined method calls:" }
+ { intrinsics-called "==== Open-coded intrinsic calls:" }
+ } [
+ nl print get keys natural-sort stack.
+ ] assoc-each
+ ] bind ;
+
+: optimizer-report. ( word -- )
+ make-report report. ;
USING: accessors namespaces assocs kernel sequences math
tools.test words sets combinators.short-circuit
stack-checker.state compiler.tree compiler.tree.builder
-compiler.tree.def-use arrays kernel.private ;
+compiler.tree.normalization compiler.tree.propagation
+compiler.tree.cleanup compiler.tree.def-use arrays kernel.private
+sorting math.order binary-search compiler.tree.checker ;
IN: compiler.tree.def-use.tests
\ compute-def-use must-infer
} 1&&
] unit-test
-! compute-def-use checks for SSA violations, so we make sure
-! some common patterns are generated correctly.
+: test-def-use ( quot -- )
+ build-tree
+ normalize
+ propagate
+ cleanup
+ compute-def-use
+ check-nodes ;
+
+! compute-def-use checks for SSA violations, so we use that to
+! ensure we generate some common patterns correctly.
{
[ [ drop ] each-integer ]
[ [ 2drop ] curry each-integer ]
[ [ 1 ] 2 [ + ] curry compose call + ]
[ [ 1 ] [ call 2 ] curry call + ]
[ [ 1 ] [ 2 ] compose swap [ 1 ] [ 2 ] if + * ]
+ [ dup slice? [ dup array? [ ] [ ] if ] [ ] if ]
+ [ dup [ drop f ] [ "A" throw ] if ]
+ [ [ <=> ] sort ]
+ [ [ <=> ] with search ]
} [
- [ ] swap [ build-tree compute-def-use drop ] curry unit-test
+ [ ] swap [ test-def-use ] curry unit-test
] each
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays namespaces assocs sequences kernel generic assocs
-classes vectors accessors combinators sets stack-checker.state
-compiler.tree compiler.tree.combinators ;
+classes vectors accessors combinators sets
+stack-checker.state
+stack-checker.branches
+compiler.tree
+compiler.tree.combinators ;
IN: compiler.tree.def-use
SYMBOL: def-use
M: #push node-uses-values drop f ;
M: #r> node-uses-values in-r>> ;
M: #phi node-uses-values
- [ phi-in-d>> ] [ phi-in-r>> ] bi append concat sift prune ;
+ [ phi-in-d>> ] [ phi-in-r>> ] bi
+ append concat remove-bottom prune ;
M: #declare node-uses-values declaration>> keys ;
M: node node-uses-values in-d>> ;
[ dup node-uses-values [ use-value ] with each ]
[ dup node-defs-values [ def-value ] with each ] bi ;
-: check-use ( uses -- )
- [ empty? [ "No use" throw ] when ]
- [ all-unique? [ "Uses not all unique" throw ] unless ] bi ;
-
-: check-def-use ( -- )
- def-use get [ nip uses>> check-use ] assoc-each ;
-
: compute-def-use ( node -- node )
H{ } clone def-use set
- dup [ node-def-use ] each-node
- check-def-use ;
+ dup [ node-def-use ] each-node ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.tree.elaboration
-
-: elaborate ( nodes -- nodes' ) ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces sequences kernel math
-combinators sets disjoint-sets fry stack-checker.state
-compiler.tree.copy-equiv ;
+combinators sets disjoint-sets fry stack-checker.state ;
IN: compiler.tree.escape-analysis.allocations
! A map from values to one of the following:
! may potentially become an allocation later
! - a sequence of values -- potentially unboxed tuple allocations
! - t -- not allocated in this procedure, can never be unboxed
-
SYMBOL: allocations
-TUPLE: slot-access slot# value ;
-
-C: <slot-access> slot-access
-
: (allocation) ( value -- value' allocations )
- resolve-copy allocations get ; inline
+ allocations get ; inline
: allocation ( value -- allocation )
- (allocation) at dup slot-access? [
- [ slot#>> ] [ value>> allocation ] bi nth
- allocation
- ] when ;
+ (allocation) at ;
-: record-allocation ( allocation value -- ) (allocation) set-at ;
+: record-allocation ( allocation value -- )
+ (allocation) set-at ;
: record-allocations ( allocations values -- )
[ record-allocation ] 2each ;
+! We track slot access to connect constructor inputs with
+! accessor outputs.
+SYMBOL: slot-accesses
+
+TUPLE: slot-access slot# value ;
+
+C: <slot-access> slot-access
+
+: record-slot-access ( out slot# in -- )
+ <slot-access> swap slot-accesses get set-at ;
+
! We track escaping values with a disjoint set.
SYMBOL: escaping-values
<disjoint-set> +escaping+ over add-atom ;
: init-escaping-values ( -- )
- copies get assoc>disjoint-set +escaping+ over add-atom
- escaping-values set ;
+ <escaping-values> escaping-values set ;
-: <slot-value> ( -- value )
- <value>
- [ introduce-value ]
- [ escaping-values get add-atom ]
- [ ]
- tri ;
+: introduce-value ( values -- )
+ escaping-values get
+ 2dup disjoint-set-member?
+ [ 2drop ] [ add-atom ] if ;
-: record-slot-access ( out slot# in -- )
- over zero? [ 3drop ] [
- <slot-access> swap record-allocation
- ] if ;
+: introduce-values ( values -- )
+ [ introduce-value ] each ;
+
+: <slot-value> ( -- value )
+ <value> dup introduce-value ;
: merge-values ( in-values out-value -- )
escaping-values get '[ , , equate ] each ;
: merge-slots ( values -- value )
<slot-value> [ merge-values ] keep ;
+: equate-values ( value1 value2 -- )
+ escaping-values get equate ;
+
: add-escaping-value ( value -- )
- +escaping+ escaping-values get equate ;
+ [
+ allocation {
+ { [ dup not ] [ drop ] }
+ { [ dup t eq? ] [ drop ] }
+ [ [ add-escaping-value ] each ]
+ } cond
+ ]
+ [ +escaping+ equate-values ] bi ;
: add-escaping-values ( values -- )
- escaping-values get
- '[ +escaping+ , equate ] each ;
+ [ add-escaping-value ] each ;
: unknown-allocation ( value -- )
[ add-escaping-value ]
: escaping-value? ( value -- ? )
+escaping+ escaping-values get equiv? ;
+DEFER: copy-value
+
+: copy-allocation ( allocation -- allocation' )
+ {
+ { [ dup not ] [ ] }
+ { [ dup t eq? ] [ ] }
+ [ [ <value> [ introduce-value ] [ copy-value ] [ ] tri ] map ]
+ } cond ;
+
+: copy-value ( from to -- )
+ [ equate-values ]
+ [ [ allocation copy-allocation ] dip record-allocation ]
+ 2bi ;
+
+: copy-slot-value ( out slot# in -- )
+ allocation {
+ { [ dup not ] [ 3drop ] }
+ { [ dup t eq? ] [ 3drop ] }
+ [ nth swap copy-value ]
+ } cond ;
+
+! Compute which tuples escape
SYMBOL: escaping-allocations
: compute-escaping-allocations ( -- )
: escaping-allocation? ( value -- ? )
escaping-allocations get key? ;
+
+: unboxed-allocation ( value -- allocation/f )
+ dup escaping-allocation? [ drop f ] [ allocation ] if ;
+
+: unboxed-slot-access? ( value -- ? )
+ slot-accesses get at*
+ [ value>> unboxed-allocation >boolean ] when ;
IN: compiler.tree.escape-analysis.branches
M: #branch escape-analysis*
- live-children sift [ (escape-analysis) ] each ;
+ [ in-d>> add-escaping-values ]
+ [ live-children sift [ (escape-analysis) ] each ]
+ bi ;
: (merge-allocations) ( values -- allocation )
[
] map ;
: merge-allocations ( in-values out-values -- )
- [ [ sift ] map ] dip
+ [ [ remove-bottom ] map ] dip
[ [ merge-values ] 2each ]
[ [ (merge-allocations) ] dip record-allocations ]
2bi ;
IN: compiler.tree.escape-analysis.tests
USING: compiler.tree.escape-analysis
compiler.tree.escape-analysis.allocations compiler.tree.builder
-compiler.tree.normalization compiler.tree.copy-equiv
+compiler.tree.normalization math.functions
compiler.tree.propagation compiler.tree.cleanup
-compiler.tree.combinators compiler.tree sequences math
+compiler.tree.combinators compiler.tree sequences math math.private
kernel tools.test accessors slots.private quotations.private
-prettyprint classes.tuple.private classes classes.tuple ;
+prettyprint classes.tuple.private classes classes.tuple
+compiler.tree.intrinsics ;
\ escape-analysis must-infer
GENERIC: count-unboxed-allocations* ( m node -- n )
: (count-unboxed-allocations) ( m node -- n )
- dup out-d>> first escaping-allocation? [ drop ] [ short. 1+ ] if ;
+ out-d>> first escaping-allocation? [ 1+ ] unless ;
M: #call count-unboxed-allocations*
- dup word>> \ <tuple-boa> =
+ dup word>> { <immutable-tuple-boa> <complex> } memq?
[ (count-unboxed-allocations) ] [ drop ] if ;
M: #push count-unboxed-allocations*
[ 3 ] [ [ <ro-box> tuple-fib ] count-unboxed-allocations ] unit-test
+: tuple-fib' ( m -- n )
+ dup 1 <= [ 1- tuple-fib' i>> ] when <ro-box> ; inline recursive
+
+[ 0 ] [ [ tuple-fib' ] count-unboxed-allocations ] unit-test
+
: bad-tuple-fib-1 ( m -- n )
dup i>> 1 <= [
drop 1 <ro-box>
] if ; inline recursive
[ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ <complex> >rect ] count-unboxed-allocations ] unit-test
+
+[ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ 1 cons boa 2 cons boa car>> ] count-unboxed-allocations ] unit-test
+
+[ 0 ] [ [ 1 cons boa 2 cons boa dup . car>> ] count-unboxed-allocations ] unit-test
compiler.tree.escape-analysis.simple ;
IN: compiler.tree.escape-analysis
+! This pass must run after propagation
+
: escape-analysis ( node -- node )
init-escaping-values
H{ } clone allocations set
+ H{ } clone slot-accesses set
dup (escape-analysis)
compute-escaping-allocations ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences compiler.tree ;
+USING: kernel sequences
+compiler.tree
+compiler.tree.def-use
+compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.escape-analysis.nodes
GENERIC: escape-analysis* ( node -- )
-M: node escape-analysis* drop ;
-
-: (escape-analysis) ( node -- ) [ escape-analysis* ] each ;
+: (escape-analysis) ( node -- )
+ [
+ [ node-defs-values introduce-values ]
+ [ escape-analysis* ]
+ bi
+ ] each ;
IN: compiler.tree.escape-analysis.recursive.tests
USING: kernel tools.test namespaces sequences
-compiler.tree.copy-equiv
compiler.tree.escape-analysis.recursive
compiler.tree.escape-analysis.allocations ;
H{ } clone allocations set
-H{ } clone copies set
+<escaping-values> escaping-values set
[ ] [ 8 [ introduce-value ] each ] unit-test
} cond ;
: check-fixed-point ( node alloc1 alloc2 -- )
- [ congruent? ] 2all? [ drop ] [
- label>> f >>fixed-point drop
- ] if ;
+ [ congruent? ] 2all? [ drop ] [ label>> f >>fixed-point drop ] if ;
: node-input-allocations ( node -- allocations )
in-d>> [ allocation ] map ;
out-d>> [ allocation ] map ;
: recursive-stacks ( #enter-recursive -- stacks )
- [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
+ [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix
+ escaping-values get '[ [ , disjoint-set-member? ] all? ] filter
+ flip ;
: analyze-recursive-phi ( #enter-recursive -- )
- [ ] [ recursive-stacks flip ] [ out-d>> ] tri
+ [ ] [ recursive-stacks ] [ out-d>> ] tri
[ [ merge-values ] 2each ]
[
[ (merge-allocations) ] dip
] 2bi ;
M: #recursive escape-analysis* ( #recursive -- )
- [
+ { 0 } clone [ USE: math
+ dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
child>>
+ [ first out-d>> introduce-values ]
[ first analyze-recursive-phi ]
[ (escape-analysis) ]
- bi
- ] until-fixed-point ;
+ tri
+ ] curry until-fixed-point ;
+
+M: #enter-recursive escape-analysis* ( #enter-recursive -- )
+ #! Handled by #recursive
+ drop ;
: return-allocations ( node -- allocations )
label>> return>> node-input-allocations ;
[ check-fixed-point ] [ drop swap out-d>> record-allocations ] 3bi ;
M: #return-recursive escape-analysis* ( #return-recursive -- )
- [ in-d>> ] [ label>> calls>> ] bi
- [ out-d>> escaping-values get '[ , equate ] 2each ] with each ;
+ [ call-next-method ]
+ [
+ [ in-d>> ] [ label>> calls>> ] bi
+ [ out-d>> escaping-values get '[ , equate ] 2each ] with each
+ ] bi ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences classes.tuple
-classes.tuple.private math math.private slots.private
+classes.tuple.private arrays math math.private slots.private
combinators dequeues search-dequeues namespaces fry classes
-stack-checker.state
+classes.algebra stack-checker.state
compiler.tree
+compiler.tree.intrinsics
compiler.tree.propagation.info
compiler.tree.escape-analysis.nodes
compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.escape-analysis.simple
-M: #introduce escape-analysis*
- value>> unknown-allocation ;
+M: #declare escape-analysis* drop ;
+
+M: #terminate escape-analysis* drop ;
+
+M: #renaming escape-analysis* inputs/outputs [ copy-value ] 2each ;
+
+M: #introduce escape-analysis* value>> unknown-allocation ;
+
+DEFER: record-literal-allocation
+
+: make-literal-slots ( seq -- values )
+ [ <slot-value> [ swap record-literal-allocation ] keep ] map ;
+
+: object-slots ( object -- slots/f )
+ #! Delegation
+ {
+ { [ dup class immutable-tuple-class? ] [ tuple-slots rest-slice ] }
+ { [ dup complex? ] [ [ real-part ] [ imaginary-part ] bi 2array ] }
+ [ drop f ]
+ } cond ;
: record-literal-allocation ( value object -- )
- dup class immutable-tuple-class? [
- tuple-slots rest-slice
- [ <slot-value> [ swap record-literal-allocation ] keep ] map
- swap record-allocation
- ] [
- drop unknown-allocation
- ] if ;
+ object-slots
+ [ make-literal-slots swap record-allocation ]
+ [ unknown-allocation ]
+ if* ;
M: #push escape-analysis*
#! Delegation.
[ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
: record-tuple-allocation ( #call -- )
- #! Delegation.
- dup dup in-d>> peek node-value-info literal>>
- class>> immutable-tuple-class? [
- [ in-d>> but-last ] [ out-d>> first ] bi
- record-allocation
- ] [ out-d>> unknown-allocations ] if ;
+ [ in-d>> but-last ] [ out-d>> first ] bi record-allocation ;
+
+: record-complex-allocation ( #call -- )
+ [ in-d>> ] [ out-d>> first ] bi record-allocation ;
+
+: slot-offset ( #call -- n/f )
+ dup in-d>>
+ [ first node-value-info class>> ]
+ [ second node-value-info literal>> ] 2bi
+ dup fixnum? [
+ {
+ { [ over tuple class<= ] [ 3 - ] }
+ { [ over complex class<= ] [ 1 - ] }
+ [ drop f ]
+ } cond nip
+ ] [ 2drop f ] if ;
: record-slot-call ( #call -- )
- [ out-d>> first ]
- [ dup in-d>> second node-value-info literal>> ]
- [ in-d>> first ] tri
- over fixnum? [
- [ 3 - ] dip record-slot-access
- ] [
- 2drop unknown-allocation
- ] if ;
+ [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
+ over [
+ [ record-slot-access ] [ copy-slot-value ] 3bi
+ ] [ 2drop unknown-allocation ] if ;
M: #call escape-analysis*
dup word>> {
- { \ <tuple-boa> [ record-tuple-allocation ] }
+ { \ <immutable-tuple-boa> [ record-tuple-allocation ] }
+ { \ <complex> [ record-complex-allocation ] }
{ \ slot [ record-slot-call ] }
[
drop
M: #return escape-analysis*
in-d>> add-escaping-values ;
+
+M: #alien-invoke escape-analysis*
+ [ in-d>> add-escaping-values ]
+ [ out-d>> unknown-allocation ]
+ bi ;
+
+M: #alien-indirect escape-analysis*
+ [ in-d>> add-escaping-values ]
+ [ out-d>> unknown-allocation ]
+ bi ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel classes.tuple classes.tuple.private math arrays
+byte-arrays words stack-checker.known-words ;
+IN: compiler.tree.intrinsics
+
+: <immutable-tuple-boa> ( ... class -- tuple )
+ "BUG: missing <immutable-tuple-boa> intrinsic" throw ;
+
+: (tuple) ( layout -- tuple )
+ "BUG: missing (tuple) intrinsic" throw ;
+
+\ (tuple) { tuple-layout } { tuple } define-primitive
+\ (tuple) make-flushable
+
+: (array) ( n -- array )
+ "BUG: missing (array) intrinsic" throw ;
+
+\ (array) { integer } { array } define-primitive
+\ (array) make-flushable
+
+: (byte-array) ( n -- byte-array )
+ "BUG: missing (byte-array) intrinsic" throw ;
+
+\ (byte-array) { integer } { byte-array } define-primitive
+\ (byte-array) make-flushable
--- /dev/null
+IN: compiler.tree.loop.detection.tests
+USING: compiler.tree.loop.detection tools.test
+kernel combinators.short-circuit math sequences accessors
+compiler.tree
+compiler.tree.builder
+compiler.tree.combinators ;
+
+[ { f f f f } ] [ f { f t f f } (tail-calls) ] unit-test
+[ { f f f t } ] [ t { f t f f } (tail-calls) ] unit-test
+[ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test
+[ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
+
+\ detect-loops must-infer
+
+: label-is-loop? ( nodes word -- ? )
+ [
+ {
+ [ drop #recursive? ]
+ [ drop label>> loop?>> ]
+ [ swap label>> word>> eq? ]
+ } 2&&
+ ] curry contains-node? ;
+
+\ label-is-loop? must-infer
+
+: label-is-not-loop? ( nodes word -- ? )
+ [
+ {
+ [ drop #recursive? ]
+ [ drop label>> loop?>> not ]
+ [ swap label>> word>> eq? ]
+ } 2&&
+ ] curry contains-node? ;
+
+\ label-is-not-loop? must-infer
+
+: loop-test-1 ( a -- )
+ dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
+
+[ t ] [
+ [ loop-test-1 ] build-tree detect-loops
+ \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+ [ loop-test-1 1 2 3 ] build-tree detect-loops
+ \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+ [ [ loop-test-1 ] each ] build-tree detect-loops
+ \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+ [ [ loop-test-1 ] each ] build-tree detect-loops
+ \ (each-integer) label-is-loop?
+] unit-test
+
+: loop-test-2 ( a -- )
+ dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
+
+[ t ] [
+ [ loop-test-2 ] build-tree detect-loops
+ \ loop-test-2 label-is-not-loop?
+] unit-test
+
+: loop-test-3 ( a -- )
+ dup [ [ loop-test-3 ] each ] [ drop ] if ; inline recursive
+
+[ t ] [
+ [ loop-test-3 ] build-tree detect-loops
+ \ loop-test-3 label-is-not-loop?
+] unit-test
+
+: loop-test-4 ( a -- )
+ dup [
+ loop-test-4
+ ] [
+ drop
+ ] if ; inline recursive
+
+[ f ] [
+ [ [ [ ] map ] map ] build-tree detect-loops
+ [
+ dup #recursive? [ label>> loop?>> not ] [ drop f ] if
+ ] contains-node?
+] unit-test
+
+: blah f ;
+
+DEFER: a
+
+: b ( -- )
+ blah [ b ] [ a ] if ; inline recursive
+
+: a ( -- )
+ blah [ b ] [ a ] if ; inline recursive
+
+[ t ] [
+ [ a ] build-tree detect-loops
+ \ a label-is-loop?
+] unit-test
+
+[ t ] [
+ [ a ] build-tree detect-loops
+ \ b label-is-loop?
+] unit-test
+
+[ t ] [
+ [ b ] build-tree detect-loops
+ \ a label-is-loop?
+] unit-test
+
+[ t ] [
+ [ a ] build-tree detect-loops
+ \ b label-is-loop?
+] unit-test
+
+DEFER: a'
+
+: b' ( -- )
+ blah [ b' b' ] [ a' ] if ; inline recursive
+
+: a' ( -- )
+ blah [ b' ] [ a' ] if ; inline recursive
+
+[ f ] [
+ [ a' ] build-tree detect-loops
+ \ a' label-is-loop?
+] unit-test
+
+[ f ] [
+ [ b' ] build-tree detect-loops
+ \ b' label-is-loop?
+] unit-test
+
+! I used to think this should be f, but doing this on pen and
+! paper almost convinced me that a loop conversion here is
+! sound.
+
+[ t ] [
+ [ b' ] build-tree detect-loops
+ \ a' label-is-loop?
+] unit-test
+
+[ f ] [
+ [ a' ] build-tree detect-loops
+ \ b' label-is-loop?
+] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.tree.loop-detection
+USING: kernel sequences namespaces assocs accessors fry
+compiler.tree dequeues search-dequeues ;
+IN: compiler.tree.loop.detection
-: detect-loops ( nodes -- nodes' ) ;
+! A loop is a #recursive which only tail calls itself, and those
+! calls are nested inside other loops only. We optimistically
+! assume all #recursive nodes are loops, disqualifying them as
+! we see evidence to the contrary.
+
+: (tail-calls) ( tail? seq -- seq' )
+ reverse [ swap [ and ] keep ] map nip reverse ;
+
+: tail-calls ( tail? node -- seq )
+ [
+ [ #phi? ]
+ [ #return? ]
+ [ #return-recursive? ]
+ tri or or
+ ] map (tail-calls) ;
+
+SYMBOL: loop-heights
+SYMBOL: loop-calls
+SYMBOL: loop-stack
+SYMBOL: work-list
+
+GENERIC: collect-loop-info* ( tail? node -- )
+
+: non-tail-label-info ( nodes -- )
+ [ f swap collect-loop-info* ] each ;
+
+: (collect-loop-info) ( tail? nodes -- )
+ [ tail-calls ] keep [ collect-loop-info* ] 2each ;
+
+: remember-loop-info ( label -- )
+ loop-stack get length swap loop-heights get set-at ;
+
+M: #recursive collect-loop-info*
+ nip
+ [
+ [
+ label>>
+ [ loop-stack [ swap suffix ] change ]
+ [ remember-loop-info ]
+ [ t >>loop? drop ]
+ tri
+ ]
+ [ t swap child>> (collect-loop-info) ] bi
+ ] with-scope ;
+
+: current-loop-nesting ( label -- labels )
+ loop-stack get swap loop-heights get at tail ;
+
+: disqualify-loop ( label -- )
+ work-list get push-front ;
+
+M: #call-recursive collect-loop-info*
+ label>>
+ swap [ dup disqualify-loop ] unless
+ dup current-loop-nesting [ loop-calls get push-at ] with each ;
+
+M: #if collect-loop-info*
+ children>> [ (collect-loop-info) ] with each ;
+
+M: #dispatch collect-loop-info*
+ children>> [ (collect-loop-info) ] with each ;
+
+M: node collect-loop-info* 2drop ;
+
+: collect-loop-info ( node -- )
+ { } loop-stack set
+ H{ } clone loop-calls set
+ H{ } clone loop-heights set
+ <hashed-dlist> work-list set
+ t swap (collect-loop-info) ;
+
+: disqualify-loops ( -- )
+ work-list get [
+ dup loop?>> [
+ [ f >>loop? drop ]
+ [ loop-calls get at [ disqualify-loop ] each ]
+ bi
+ ] [ drop ] if
+ ] slurp-dequeue ;
+
+: detect-loops ( nodes -- nodes )
+ dup collect-loop-info disqualify-loops ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.tree.loop.inversion
+
+: invert-loops ( nodes -- nodes' ) ;
IN: compiler.tree.normalization.tests
USING: compiler.tree.builder compiler.tree.normalization
-compiler.tree sequences accessors tools.test kernel ;
+compiler.tree sequences accessors tools.test kernel math ;
\ count-introductions must-infer
\ fixup-enter-recursive must-infer
[ recursive-inputs ]
[ normalize recursive-inputs ] bi
] unit-test
+
+[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize drop ] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry namespaces sequences math accessors kernel arrays
-stack-checker.backend stack-checker.inlining compiler.tree
+stack-checker.backend
+stack-checker.branches
+stack-checker.inlining
+compiler.tree
compiler.tree.combinators ;
IN: compiler.tree.normalization
bi ;
: eliminate-phi-introductions ( introductions seq terminated -- seq' )
- [ flip ] dip [ [ nip ] [ over length tail append ] if ] 3map flip ;
+ [ flip ] dip [
+ [ nip ] [
+ dup [ +bottom+ eq? ] left-trim
+ [ [ length ] bi@ - tail* ] keep append
+ ] if
+ ] 3map flip ;
M: #phi eliminate-introductions*
remaining-introductions get swap dup terminated>>
--- /dev/null
+USING: compiler.tree.optimizer tools.test ;
+IN: compiler.tree.optimizer.tests
+
+\ optimize-tree must-infer
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.tree.normalization compiler.tree.copy-equiv
-compiler.tree.propagation compiler.tree.cleanup
-compiler.tree.def-use compiler.tree.untupling
-compiler.tree.dead-code compiler.tree.strength-reduction
-compiler.tree.loop-detection compiler.tree.branch-fusion ;
+USING: compiler.tree.normalization
+compiler.tree.propagation
+compiler.tree.cleanup
+compiler.tree.escape-analysis
+compiler.tree.tuple-unboxing
+compiler.tree.def-use
+compiler.tree.dead-code
+compiler.tree.strength-reduction
+compiler.tree.loop.detection
+compiler.tree.loop.inversion
+compiler.tree.branch-fusion ;
IN: compiler.tree.optimizer
: optimize-tree ( nodes -- nodes' )
normalize
propagate
cleanup
- compute-def-use
+ detect-loops
+ invert-loops
+ fuse-branches
+ escape-analysis
unbox-tuples
compute-def-use
remove-dead-code
- strength-reduce
- detect-loops
- fuse-branches
- elaborate ;
+ strength-reduce ;
! See http://factorcode.org/license.txt for BSD license.
USING: fry kernel sequences assocs accessors namespaces
math.intervals arrays classes.algebra combinators
+stack-checker.branches
compiler.tree
compiler.tree.def-use
compiler.tree.combinators
: compute-phi-input-infos ( phi-in -- phi-info )
infer-children-data get
- '[ , [ [ [ value-info ] [ null-info ] if* ] bind ] 2map ] map ;
+ '[
+ , [
+ [
+ dup +bottom+ eq?
+ [ drop null-info ] [ value-info ] if
+ ] bind
+ ] 2map
+ ] map ;
: annotate-phi-inputs ( #phi -- )
dup phi-in-d>> compute-phi-input-infos >>phi-info-d
M: #phi propagate-after ( #phi -- )
condition-value get [
[ out-d>> ] [ phi-in-d>> ] [ phi-info-d>> ] tri
- 3array flip [
- first3 [ possible-boolean-values ] map
+ [
+ [ possible-boolean-values ] map
branch-phi-constraints
- ] each
+ ] 3each
] [ drop ] if ;
M: #phi propagate-around ( #phi -- )
USING: arrays assocs math math.intervals kernel accessors
sequences namespaces classes classes.algebra
combinators words
-compiler.tree compiler.tree.propagation.info
-compiler.tree.copy-equiv ;
+compiler.tree
+compiler.tree.propagation.info
+compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.constraints
! A constraint is a statement about a value.
--- /dev/null
+IN: compiler.tree.propagation.copy.tests
+USING: compiler.tree.propagation.copy tools.test namespaces kernel
+assocs ;
+
+H{ } clone copies set
+
+[ ] [ 0 introduce-value ] unit-test
+[ ] [ 1 introduce-value ] unit-test
+[ ] [ 1 2 is-copy-of ] unit-test
+[ ] [ 2 3 is-copy-of ] unit-test
+[ ] [ 2 4 is-copy-of ] unit-test
+[ ] [ 4 5 is-copy-of ] unit-test
+[ ] [ 0 6 is-copy-of ] unit-test
+
+[ 0 ] [ 0 resolve-copy ] unit-test
+[ 1 ] [ 5 resolve-copy ] unit-test
+
+! Make sure that we did path compression
+[ 1 ] [ 5 copies get at ] unit-test
+
+[ 1 ] [ 1 resolve-copy ] unit-test
+[ 1 ] [ 2 resolve-copy ] unit-test
+[ 1 ] [ 3 resolve-copy ] unit-test
+[ 1 ] [ 4 resolve-copy ] unit-test
+[ 0 ] [ 6 resolve-copy ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces sequences assocs math kernel accessors fry
+combinators sets locals
+stack-checker.branches
+compiler.tree
+compiler.tree.def-use
+compiler.tree.combinators ;
+IN: compiler.tree.propagation.copy
+
+! Two values are copy-equivalent if they are always identical
+! at run-time ("DS" relation). This is just a weak form of
+! value numbering.
+
+! Mapping from values to their canonical leader
+SYMBOL: copies
+
+:: compress-path ( source assoc -- destination )
+ [let | destination [ source assoc at ] |
+ source destination = [ source ] [
+ [let | destination' [ destination assoc compress-path ] |
+ destination' destination = [
+ destination' source assoc set-at
+ ] unless
+ destination'
+ ]
+ ] if
+ ] ;
+
+: resolve-copy ( copy -- val ) copies get compress-path ;
+
+: is-copy-of ( val copy -- ) copies get set-at ;
+
+: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
+
+: introduce-value ( val -- ) copies get conjoin ;
+
+GENERIC: compute-copy-equiv* ( node -- )
+
+M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
+
+: compute-phi-equiv ( inputs outputs -- )
+ #! An output is a copy of every input if all inputs are
+ #! copies of the same original value.
+ [
+ swap remove-bottom [ resolve-copy ] map
+ dup [ all-equal? ] [ empty? not ] bi and
+ [ first swap is-copy-of ] [ 2drop ] if
+ ] 2each ;
+
+M: #phi compute-copy-equiv*
+ [ [ phi-in-d>> ] [ out-d>> ] bi compute-phi-equiv ]
+ [ [ phi-in-r>> ] [ out-r>> ] bi compute-phi-equiv ] bi ;
+
+M: node compute-copy-equiv* drop ;
+
+: compute-copy-equiv ( node -- )
+ [ node-defs-values [ introduce-value ] each ]
+ [ compute-copy-equiv* ]
+ bi ;
USING: assocs classes classes.algebra kernel
accessors math math.intervals namespaces sequences words
combinators combinators.short-circuit arrays
-compiler.tree.copy-equiv ;
+compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
: false-class? ( class -- ? ) \ f class<= ;
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
M: quotation splicing-nodes
- [ [ out-d>> ] [ in-d>> ] bi ] dip
- build-tree-with
- rot #copy suffix
- normalize ;
+ build-sub-tree normalize ;
: propagate-body ( #call -- )
body>> (propagate) ;
USING: sequences accessors kernel assocs sequences
compiler.tree
compiler.tree.def-use
-compiler.tree.copy-equiv
+compiler.tree.propagation.copy
compiler.tree.propagation.info ;
IN: compiler.tree.propagation.nodes
USING: accessors kernel sequences namespaces hashtables
compiler.tree
compiler.tree.def-use
-compiler.tree.copy-equiv
+compiler.tree.propagation.copy
compiler.tree.propagation.info
compiler.tree.propagation.nodes
compiler.tree.propagation.simple
compiler.tree.propagation.known-words ;
IN: compiler.tree.propagation
+! This pass must run after normalization
+
: propagate ( node -- node )
H{ } clone copies set
H{ } clone constraints set
combinators namespaces
stack-checker.inlining
compiler.tree
-compiler.tree.copy-equiv
compiler.tree.combinators
+compiler.tree.propagation.copy
compiler.tree.propagation.info
compiler.tree.propagation.nodes
compiler.tree.propagation.simple
: unify-recursive-stacks ( stacks initial -- infos )
over empty? [ nip ] [
[
- [ sift value-infos-union ] dip
+ [ value-infos-union ] dip
[ generalize-counter ] keep
value-info-union
] 2map
M: #call propagate-after
dup word>> "input-classes" word-prop dup
[ propagate-input-classes ] [ 2drop ] if ;
+
+M: #alien-invoke propagate-before
+ out-d>> [ object-info swap set-value-info ] each ;
+
+M: #alien-indirect propagate-before
+ out-d>> [ object-info swap set-value-info ] each ;
swap 1array >>out-d
swap >>literal ;
-TUPLE: #shuffle < node mapping in-d out-d ;
+TUPLE: #renaming < node ;
+
+TUPLE: #shuffle < #renaming mapping in-d out-d ;
: #shuffle ( inputs outputs mapping -- node )
\ #shuffle new
: #drop ( inputs -- node )
{ } { } #shuffle ;
-TUPLE: #>r < node in-d out-r ;
+TUPLE: #>r < #renaming in-d out-r ;
: #>r ( inputs outputs -- node )
\ #>r new
swap >>out-r
swap >>in-d ;
-TUPLE: #r> < node in-r out-d ;
+TUPLE: #r> < #renaming in-r out-d ;
: #r> ( inputs outputs -- node )
\ #r> new
swap >>in-d
swap >>label ;
-TUPLE: #return-recursive < node in-d out-d label ;
+TUPLE: #return-recursive < #renaming in-d out-d label ;
: #return-recursive ( label inputs outputs -- node )
\ #return-recursive new
swap >>in-d
swap >>label ;
-TUPLE: #copy < node in-d out-d ;
+TUPLE: #copy < #renaming in-d out-d ;
: #copy ( inputs outputs -- node )
\ #copy new
swap >>out-d
swap >>in-d ;
+TUPLE: #alien-node < node params ;
+
+: new-alien-node ( params class -- node )
+ new
+ over in-d>> >>in-d
+ over out-d>> >>out-d
+ swap >>params ; inline
+
+TUPLE: #alien-invoke < #alien-node in-d out-d ;
+
+: #alien-invoke ( params -- node )
+ \ #alien-invoke new-alien-node ;
+
+TUPLE: #alien-indirect < #alien-node in-d out-d ;
+
+: #alien-indirect ( params -- node )
+ \ #alien-indirect new-alien-node ;
+
+TUPLE: #alien-callback < #alien-node ;
+
+: #alien-callback ( params -- node )
+ \ #alien-callback new
+ swap >>params ;
+
: node, ( node -- ) stack-visitor get push ;
+GENERIC: inputs/outputs ( #renaming -- inputs outputs )
+
+M: #shuffle inputs/outputs mapping>> unzip swap ;
+M: #>r inputs/outputs [ in-d>> ] [ out-r>> ] bi ;
+M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ;
+M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
+M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
+
+: shuffle-effect ( #shuffle -- effect )
+ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri
+ [ at ] curry map
+ <effect> ;
+
M: vector child-visitor V{ } clone ;
M: vector #introduce, #introduce node, ;
M: vector #call, #call node, ;
M: vector #declare, #declare node, ;
M: vector #recursive, #recursive node, ;
M: vector #copy, #copy node, ;
+M: vector #alien-invoke, #alien-invoke node, ;
+M: vector #alien-indirect, #alien-indirect node, ;
+M: vector #alien-callback, #alien-callback node, ;
--- /dev/null
+IN: compiler.tree.tuple-unboxing.tests
+USING: tools.test compiler.tree.tuple-unboxing compiler.tree
+compiler.tree.builder compiler.tree.normalization
+compiler.tree.propagation compiler.tree.cleanup
+compiler.tree.escape-analysis compiler.tree.tuple-unboxing
+compiler.tree.checker compiler.tree.def-use kernel accessors
+sequences math math.private sorting math.order binary-search
+sequences.private slots.private ;
+
+\ unbox-tuples must-infer
+
+: test-unboxing ( quot -- )
+ build-tree
+ normalize
+ propagate
+ cleanup
+ escape-analysis
+ unbox-tuples
+ check-nodes ;
+
+TUPLE: cons { car read-only } { cdr read-only } ;
+
+TUPLE: empty-tuple ;
+
+{
+ [ 1 2 cons boa [ car>> ] [ cdr>> ] bi ]
+ [ empty-tuple boa drop ]
+ [ cons boa [ car>> ] [ cdr>> ] bi ]
+ [ [ 1 cons boa ] [ 2 cons boa ] if car>> ]
+ [ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
+ [ 2 cons boa { [ ] [ ] } dispatch ]
+ [ dup [ drop f ] [ "A" throw ] if ]
+ [ [ ] [ ] curry curry dup 3 slot swap 4 slot dup 3 slot swap 4 slot drop ]
+ [ [ ] [ ] curry curry call ]
+ [ <complex> <complex> dup 1 slot drop 2 slot drop ]
+ [ 1 cons boa over [ "A" throw ] when car>> ]
+ [ [ <=> ] sort ]
+ [ [ <=> ] with search ]
+} [ [ ] swap [ test-unboxing ] curry unit-test ] each
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs accessors kernel combinators
+classes.algebra sequences sequences.deep slots.private
+classes.tuple.private math math.private arrays
+stack-checker.branches
+compiler.tree
+compiler.tree.intrinsics
+compiler.tree.combinators
+compiler.tree.escape-analysis.simple
+compiler.tree.escape-analysis.allocations ;
+IN: compiler.tree.tuple-unboxing
+
+! This pass must run after escape analysis
+
+GENERIC: unbox-tuples* ( node -- node/nodes )
+
+: unbox-output? ( node -- values )
+ out-d>> first unboxed-allocation ;
+
+: (expand-#push) ( object value -- nodes )
+ dup unboxed-allocation dup [
+ [ object-slots ] [ drop ] [ ] tri*
+ [ (expand-#push) ] 2map
+ ] [
+ drop #push
+ ] if ;
+
+: expand-#push ( #push -- nodes )
+ [ literal>> ] [ out-d>> first ] bi (expand-#push) ;
+
+M: #push unbox-tuples* ( #push -- nodes )
+ dup unbox-output? [ expand-#push ] when ;
+
+: unbox-<tuple-boa> ( #call -- nodes )
+ dup unbox-output? [ in-d>> 1 tail* #drop ] when ;
+
+: unbox-<complex> ( #call -- nodes )
+ dup unbox-output? [ drop { } ] when ;
+
+: (flatten-values) ( values -- values' )
+ [ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
+
+: flatten-values ( values -- values' )
+ (flatten-values) flatten ;
+
+: prepare-slot-access ( #call -- tuple-values outputs slot-values )
+ [ in-d>> flatten-values ]
+ [ out-d>> flatten-values ]
+ [
+ out-d>> first slot-accesses get at
+ [ slot#>> ] [ value>> ] bi allocation nth
+ 1array flatten-values
+ ] tri ;
+
+: slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle )
+ [ drop ] [ zip ] 2bi #shuffle ;
+
+: unbox-slot-access ( #call -- nodes )
+ dup out-d>> first unboxed-slot-access? [
+ [ in-d>> second 1array #drop ]
+ [ prepare-slot-access slot-access-shuffle ]
+ bi 2array
+ ] when ;
+
+M: #call unbox-tuples*
+ dup word>> {
+ { \ <immutable-tuple-boa> [ unbox-<tuple-boa> ] }
+ { \ <complex> [ unbox-<complex> ] }
+ { \ slot [ unbox-slot-access ] }
+ [ drop ]
+ } case ;
+
+M: #declare unbox-tuples*
+ #! We don't look at declarations after propagation anyway.
+ f >>declaration ;
+
+M: #copy unbox-tuples*
+ [ flatten-values ] change-in-d
+ [ flatten-values ] change-out-d ;
+
+M: #>r unbox-tuples*
+ [ flatten-values ] change-in-d
+ [ flatten-values ] change-out-r ;
+
+M: #r> unbox-tuples*
+ [ flatten-values ] change-in-r
+ [ flatten-values ] change-out-d ;
+
+M: #shuffle unbox-tuples*
+ [ flatten-values ] change-in-d
+ [ flatten-values ] change-out-d
+ [ unzip [ flatten-values ] bi@ zip ] change-mapping ;
+
+M: #terminate unbox-tuples*
+ [ flatten-values ] change-in-d ;
+
+M: #phi unbox-tuples*
+ [ flip [ flatten-values ] map pad-with-bottom flip ] change-phi-in-d
+ [ flip [ flatten-values ] map pad-with-bottom flip ] change-phi-in-r
+ [ flatten-values ] change-out-d
+ [ flatten-values ] change-out-r ;
+
+M: #recursive unbox-tuples*
+ [ flatten-values ] change-in-d ;
+
+M: #enter-recursive unbox-tuples*
+ [ flatten-values ] change-in-d
+ [ flatten-values ] change-out-d ;
+
+M: #call-recursive unbox-tuples*
+ [ flatten-values ] change-in-d
+ [ flatten-values ] change-out-d ;
+
+M: #return-recursive unbox-tuples*
+ [ flatten-values ] change-in-d
+ [ flatten-values ] change-out-d ;
+
+! These nodes never participate in unboxing
+: assert-not-unboxed ( values -- )
+ dup array?
+ [ [ unboxed-allocation ] contains? ] [ unboxed-allocation ] if
+ [ "Unboxing wrong value" throw ] when ;
+
+M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ;
+
+M: #return unbox-tuples* dup in-d>> assert-not-unboxed ;
+
+M: #introduce unbox-tuples* dup value>> assert-not-unboxed ;
+
+M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ;
+
+M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ;
+
+: unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ;
+++ /dev/null
-IN: compiler.tree.untupling.tests
-USING: assocs math kernel quotations.private slots.private
-compiler.tree.builder
-compiler.tree.def-use
-compiler.tree.copy-equiv
-compiler.tree.untupling
-tools.test ;
-
-: check-untupling ( quot -- sizes )
- build-tree
- compute-copy-equiv
- compute-def-use
- compute-untupling
- values ;
-
-[ { } ] [ [ 1 [ + ] curry ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 1 [ + ] curry drop ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 1 [ + ] curry 3 slot ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 1 [ + ] curry 3 slot drop ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 1 [ + ] curry uncurry ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test
-
-[ { } ] [ [ [ 1 [ + ] curry ] [ [ ] ] if ] check-untupling ] unit-test
-
-[ { 2 2 } ] [
- [ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if uncurry ] check-untupling
-] unit-test
-
-[ { } ] [
- [ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if ] check-untupling
-] unit-test
-
-[ { 2 2 2 } ] [
- [ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if uncurry ] check-untupling
-] unit-test
-
-[ { 2 2 } ] [
- [ [ 1 [ + ] curry 4 ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if uncurry ] if ] check-untupling
-] unit-test
-
-[ { } ] [
- [ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if ] check-untupling
-] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors slots.private kernel namespaces disjoint-sets
-math sequences assocs classes.tuple.private combinators fry sets
-compiler.tree compiler.tree.combinators compiler.tree.copy-equiv
-compiler.tree.dataflow-analysis
-compiler.tree.dataflow-analysis.backward ;
-IN: compiler.tree.untupling
-
-SYMBOL: escaping-values
-
-: mark-escaping-values ( node -- )
- in-d>> escaping-values get '[ resolve-copy , conjoin ] each ;
-
-SYMBOL: untupling-candidates
-
-: untupling-candidate ( #call class -- )
- #! 1- for delegate
- size>> 1- swap out-d>> first resolve-copy
- untupling-candidates get set-at ;
-
-GENERIC: compute-untupling* ( node -- )
-
-M: #call compute-untupling*
- dup word>> {
- { \ <tuple-boa> [ dup in-d>> peek untupling-candidate ] }
- { \ curry [ \ curry tuple-layout untupling-candidate ] }
- { \ compose [ \ compose tuple-layout untupling-candidate ] }
- { \ slot [ drop ] }
- [ drop mark-escaping-values ]
- } case ;
-
-M: #return compute-untupling* mark-escaping-values ;
-
-M: node compute-untupling* drop ;
-
-GENERIC: check-consistency* ( node -- )
-
-: check-value-consistency ( out-value in-values -- )
- swap escaping-values get key? [
- escaping-values get '[ , conjoin ] each
- ] [
- untupling-candidates get 2dup '[ , at ] map all-equal?
- [ 2drop ] [ '[ , delete-at ] each ] if
- ] if ;
-
-M: #phi check-consistency*
- [ [ out-d>> ] [ phi-in-d>> ] bi [ check-value-consistency ] 2each ]
- [ [ out-r>> ] [ phi-in-r>> ] bi [ check-value-consistency ] 2each ]
- bi ;
-
-M: node check-consistency* drop ;
-
-: compute-untupling ( node -- assoc )
- H{ } clone escaping-values set
- H{ } clone untupling-candidates set
- [ [ compute-untupling* ] each-node ]
- [ [ check-consistency* ] each-node ] bi
- untupling-candidates get escaping-values get assoc-diff ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences accessors combinators math namespaces
+init sets words
+alien alien.c-types
+stack-checker.backend stack-checker.errors stack-checker.visitor ;
+IN: stack-checker.alien
+
+TUPLE: alien-node-params return parameters abi in-d out-d ;
+
+TUPLE: alien-invoke-params < alien-node-params library function ;
+
+TUPLE: alien-indirect-params < alien-node-params ;
+
+TUPLE: alien-callback-params < alien-node-params quot xt ;
+
+: pop-parameters ( -- seq )
+ pop-literal nip [ expand-constants ] map ;
+
+: param-prep-quot ( node -- quot )
+ parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
+
+: alien-stack ( params extra -- )
+ over parameters>> length + consume-d >>in-d
+ dup return>> "void" = 0 1 ? produce-d >>out-d
+ drop ;
+
+: return-prep-quot ( node -- quot )
+ return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
+
+: infer-alien-invoke ( -- )
+ alien-invoke-params new
+ ! Compile-time parameters
+ pop-parameters >>parameters
+ pop-literal nip >>function
+ pop-literal nip >>library
+ pop-literal nip >>return
+ ! Quotation which coerces parameters to required types
+ dup param-prep-quot recursive-state get infer-quot
+ ! Set ABI
+ dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
+ ! Magic #: consume exactly the number of inputs
+ dup 0 alien-stack
+ ! Add node to IR
+ dup #alien-invoke,
+ ! Quotation which coerces return value to required type
+ return-prep-quot recursive-state get infer-quot ;
+
+: infer-alien-indirect ( -- )
+ alien-indirect-params new
+ ! Compile-time parameters
+ pop-literal nip >>abi
+ pop-parameters >>parameters
+ pop-literal nip >>return
+ ! Quotation which coerces parameters to required types
+ dup param-prep-quot [ dip ] curry recursive-state get infer-quot
+ ! Magic #: consume the function pointer, too
+ dup 1 alien-stack
+ ! Add node to IR
+ dup #alien-indirect,
+ ! Quotation which coerces return value to required type
+ return-prep-quot recursive-state get infer-quot ;
+
+! Callbacks are registered in a global hashtable. If you clear
+! this hashtable, they will all be blown away by code GC, beware
+SYMBOL: callbacks
+
+[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
+
+: register-callback ( word -- ) callbacks get conjoin ;
+
+: callback-bottom ( params -- )
+ xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
+ recursive-state get infer-quot ;
+
+: infer-alien-callback ( -- )
+ alien-callback-params new
+ pop-literal nip >>quot
+ pop-literal nip >>abi
+ pop-parameters >>parameters
+ pop-literal nip >>return
+ gensym >>xt
+ dup callback-bottom
+ #alien-callback, ;
: balanced? ( pairs -- ? )
[ second ] filter [ first2 length - ] map all-equal? ;
+SYMBOL: +bottom+
+
: unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
- dup [ [ - f <repetition> ] dip append ] [ 3drop f ] if ;
+ dup [ [ - +bottom+ <repetition> ] dip append ] [ 3drop f ] if ;
-: pad-with-f ( seq -- newseq )
- dup [ length ] map supremum '[ , f pad-left ] map ;
+: pad-with-bottom ( seq -- newseq )
+ dup empty? [
+ dup [ length ] map supremum
+ '[ , +bottom+ pad-left ] map
+ ] unless ;
: phi-inputs ( max-d-in pairs -- newseq )
dup empty? [ nip ] [
swap '[ , _ first2 unify-inputs ] map
- pad-with-f
+ pad-with-bottom
flip
] if ;
+: remove-bottom ( seq -- seq' )
+ +bottom+ swap remove ;
+
: unify-values ( values -- phi-out )
- sift dup empty? [ drop <value> ] [
+ remove-bottom
+ dup empty? [ drop <value> ] [
[ known ] map dup all-eq?
[ first make-known ] [ drop <value> ] if
] if ;
: (inline-word) ( word label -- )
[ [ def>> ] keep ] dip infer-quot-recursive ;
-TUPLE: inline-recursive
+TUPLE: inline-recursive < identity-tuple
+id
word
enter-out enter-recursive
return calls
fixed-point
-introductions ;
+introductions
+loop? ;
+
+M: inline-recursive hashcode* id>> hashcode* ;
+
+: inlined-block? ( word -- ? ) "inlined-block" word-prop ;
: <inline-recursive> ( word -- label )
- inline-recursive new swap >>word ;
+ inline-recursive new
+ gensym dup t "inlined-block" set-word-prop >>id
+ swap >>word ;
: quotation-param? ( obj -- ? )
dup pair? [ second effect? ] [ drop f ] if ;
strings.private system threads.private classes.tuple
classes.tuple.private vectors vectors.private words definitions
words.private assocs summary compiler.units system.private
-combinators locals.backend stack-checker.state
-stack-checker.backend stack-checker.branches
-stack-checker.errors stack-checker.transforms
-stack-checker.visitor ;
+combinators locals.backend
+stack-checker.state
+stack-checker.backend
+stack-checker.branches
+stack-checker.errors
+stack-checker.transforms
+stack-checker.visitor
+stack-checker.alien ;
IN: stack-checker.known-words
: infer-primitive ( word -- )
{ \ get-local [ infer-get-local ] }
{ \ drop-locals [ infer-drop-locals ] }
{ \ do-primitive [ \ do-primitive cannot-infer-effect ] }
+ { \ alien-invoke [ infer-alien-invoke ] }
+ { \ alien-indirect [ infer-alien-indirect ] }
+ { \ alien-callback [ infer-alien-callback ] }
} case ;
{
- >r r> declare call curry compose
- execute if dispatch <tuple-boa>
- (throw) load-locals get-local drop-locals
- do-primitive
+ >r r> declare call curry compose execute if dispatch
+ <tuple-boa> (throw) load-locals get-local drop-locals
+ do-primitive alien-invoke alien-indirect alien-callback
} [ t +special+ set-word-prop ] each
{ call execute dispatch load-locals get-local drop-locals }
[ t "no-compile" set-word-prop ] each
+SYMBOL: +primitive+
+
: non-inline-word ( word -- )
dup +called+ depends-on
{
{ [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] }
{ [ dup +special+ word-prop ] [ infer-special ] }
- { [ dup primitive? ] [ infer-primitive ] }
- { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
- { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
+ { [ dup +primitive+ word-prop ] [ infer-primitive ] }
{ [ dup +transform-quot+ word-prop ] [ apply-transform ] }
{ [ dup "macro" word-prop ] [ apply-macro ] }
+ { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
+ { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
{ [ dup recursive-label ] [ call-recursive-word ] }
[ dup infer-word apply-word/effect ]
} cond ;
: define-primitive ( word inputs outputs -- )
+ [ 2drop t +primitive+ set-word-prop ]
[ drop "input-classes" set-word-prop ]
[ nip "default-output-classes" set-word-prop ]
- 3bi ;
+ 3tri ;
! Stack effects for all primitives
\ fixnum< { fixnum fixnum } { object } define-primitive
SYMBOL: +transform-quot+
SYMBOL: +transform-n+
-: (apply-transform) ( quot n -- newquot )
- dup zero? [
- drop recursive-state get 1array
- ] [
- consume-d
- [ #drop, ]
- [ [ literal value>> ] map ]
- [ first literal recursion>> ] tri prefix
- ] if
- swap with-datastack ;
+: give-up-transform ( word -- )
+ dup recursive-label
+ [ call-recursive-word ]
+ [ dup infer-word apply-word/effect ]
+ if ;
+
+: ((apply-transform)) ( word quot stack -- )
+ swap with-datastack first2
+ dup [ swap infer-quot drop ] [ 2drop give-up-transform ] if ;
+ inline
+
+: (apply-transform) ( word quot n -- )
+ dup ensure-d [ known literal? ] all? [
+ dup empty? [
+ drop recursive-state get 1array
+ ] [
+ consume-d
+ [ #drop, ]
+ [ [ literal value>> ] map ]
+ [ first literal recursion>> ] tri prefix
+ ] if
+ ((apply-transform))
+ ] [ 2drop give-up-transform ] if ;
: apply-transform ( word -- )
[ +inlined+ depends-on ] [
+ [ ]
[ +transform-quot+ word-prop ]
[ +transform-n+ word-prop ]
- bi (apply-transform)
- first2 swap infer-quot
+ tri
+ (apply-transform)
] bi ;
: apply-macro ( word -- )
[ +inlined+ depends-on ] [
+ [ ]
[ "macro" word-prop ]
[ "declared-effect" word-prop in>> length ]
- bi (apply-transform)
- first2 swap infer-quot
+ tri
+ (apply-transform)
] bi ;
: define-transform ( word quot n -- )
\ spread [ spread>quot ] 1 define-transform
+\ (call-next-method) [
+ [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
+] 2 define-transform
+
+! Constructors
\ boa [
dup tuple-class? [
dup +inlined+ depends-on
[ "boa-check" word-prop ]
[ tuple-layout '[ , <tuple-boa> ] ]
bi append
+ ] [ drop f ] if
+] 1 define-transform
+
+\ new [
+ dup tuple-class? [
+ dup +inlined+ depends-on
+ dup all-slots rest-slice ! delegate slot
+ [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make
+ ] [ drop f ] if
+] 1 define-transform
+
+! Membership testing
+: bit-member-n 256 ; inline
+
+: bit-member? ( seq -- ? )
+ #! Can we use a fast byte array test here?
+ {
+ { [ dup length 8 < ] [ f ] }
+ { [ dup [ integer? not ] contains? ] [ f ] }
+ { [ dup [ 0 < ] contains? ] [ f ] }
+ { [ dup [ bit-member-n >= ] contains? ] [ f ] }
+ [ t ]
+ } cond nip ;
+
+: bit-member-seq ( seq -- flags )
+ bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ;
+
+: exact-float? ( f -- ? )
+ dup float? [ dup >integer >float = ] [ drop f ] if ; inline
+
+: bit-member-quot ( seq -- newquot )
+ [
+ bit-member-seq ,
+ [
+ {
+ { [ over fixnum? ] [ ?nth 1 eq? ] }
+ { [ over bignum? ] [ ?nth 1 eq? ] }
+ { [ over exact-float? ] [ ?nth 1 eq? ] }
+ [ 2drop f ]
+ } cond
+ ] %
+ ] [ ] make ;
+
+: member-quot ( seq -- newquot )
+ dup bit-member? [
+ bit-member-quot
] [
- \ boa \ no-method boa time-bomb
- ] if
+ [ literalize [ t ] ] { } map>assoc
+ [ drop f ] suffix [ case ] curry
+ ] if ;
+
+\ member? [
+ dup sequence? [ member-quot ] [ drop f ] if
] 1 define-transform
-\ (call-next-method) [
- [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
-] 2 define-transform
+: memq-quot ( seq -- newquot )
+ [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
+ [ drop f ] suffix [ nip cond ] curry ;
+
+\ memq? [
+ dup sequence? [ memq-quot ] [ drop f ] if
+] 1 define-transform
! Deprecated
\ get-slots [ [ 1quotation ] map [ cleave ] curry ] 1 define-transform
M: f #recursive, 2drop 2drop ;
M: f #copy, 2drop ;
M: f #drop, drop ;
+M: f #alien-invoke, drop ;
+M: f #alien-indirect, drop ;
+M: f #alien-callback, drop ;
HOOK: #return-recursive, stack-visitor ( label inputs outputs -- )
HOOK: #recursive, stack-visitor ( word label inputs visitor -- )
HOOK: #copy, stack-visitor ( inputs outputs -- )
+HOOK: #alien-invoke, stack-visitor ( params -- )
+HOOK: #alien-indirect, stack-visitor ( params -- )
+HOOK: #alien-callback, stack-visitor ( params -- )
projects / factor.git / commitdiff