--- /dev/null
+Dave Carlton
--- /dev/null
+USING: classes kernel parser words ;
+IN: classes.parser
+
+: create-class ( string vocab -- word )
+ create-word dup t "defining-class" set-word-prop
+ dup set-last-word
+ dup create-predicate-word drop ;
--- /dev/null
+! Copyright (C) 2015-2017 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays classes combinators
+combinators.short-circuit combinators.smart compiler.units
+effects fry hashtables.private kernel listener locals math
+math.order math.parser namespaces prettyprint sequences sorting
+sequences.deep sequences.extras sets splitting strings
+ui.gadgets vectors vocabs.parser definitions ;
+QUALIFIED: vocabs
+QUALIFIED: words
+IN: code
+
+TUPLE: element < identity-tuple name parent contents default-name target ;
+
+TUPLE: vocab < element ;
+TUPLE: word < element defined? result ;
+
+TUPLE: node < element quoted? ;
+TUPLE: introduce < node id ;
+TUPLE: return < node ;
+TUPLE: call < node completion ;
+TUPLE: text < node ;
+TUPLE: setter < node id ;
+TUPLE: getter < node id ;
+
+TUPLE: result < element ;
+
+UNION: input/output introduce return ;
+UNION: link setter getter ;
+UNION: source introduce text getter ;
+UNION: sink return setter ;
+
+PREDICATE: quoted-node < node quoted?>> ;
+
+SYMBOL: skov-root
+vocab new "●" >>name skov-root set-global
+
+SYMBOL: left
+SYMBOL: right
+
+: arity ( node -- n )
+ ! returns the number of children of a node
+ contents>> length ;
+
+: walk ( node -- seq )
+ [ contents>> [ walk ] map ] [ ] bi 2array ;
+
+: sort-tree ( word -- seq )
+ contents>> [ walk ] map flatten ;
+
+: vocabs ( elt -- seq ) contents>> [ vocab? ] filter ;
+: words ( elt -- seq ) contents>> [ word? ] filter ;
+: calls ( elt -- seq ) sort-tree [ call? ] filter ;
+: introduces ( elt -- seq ) sort-tree [ introduce? ] filter ;
+: returns ( elt -- seq ) contents>> [ return? ] filter ;
+: links ( elt -- seq ) sort-tree [ link? ] filter ;
+
+: own-introduces ( elt -- seq )
+ ! returns all "introduce" nodes in the child tree but ignores quoted nodes
+ contents>> [ [ introduce? ] filter ]
+ [ [ quoted?>> ] reject [ own-introduces ] map-concat ] bi
+ append ;
+
+:: add-element ( elt child-elt -- elt )
+ ! sets an existing element as the child of another existing element
+ child-elt elt >>parent elt [ ?push ] change-contents ;
+
+: add-from-class ( elt child-class -- elt )
+ ! sets a new element of a certain class as the child of an existing element
+ new add-element ;
+
+: add-with-name ( elt child-name child-class -- elt )
+ ! sets a new element of a certain class and with a certain name
+ ! as the child of an existing element
+ new swap >>name add-element ;
+
+: ?forget ( elt -- elt )
+ ! removes the corresponding Factor vocabulary or word
+ dup target>> [ [ forget ] with-compilation-unit ] when* ;
+
+:: remove-element ( elt -- parent )
+ ! removes a node from its parent
+ elt ?forget parent>> [ elt swap remove-eq ] change-contents ;
+
+: replace* ( seq old rep -- seq )
+ ! replaces an element with another element in a sequence
+ [ 1array ] bi@ replace ;
+
+:: replace-element ( old rep -- rep )
+ ! replaces an element with another element
+ old parent>> [ old rep old parent>> >>parent replace* ] change-contents drop rep ;
+
+: replace-parent ( node -- node )
+ ! replaces the parent of the node with the node
+ dup parent>> [ node? ] [ swap replace-element ] smart-when* ;
+
+: insert-new-parent ( old -- new )
+ ! replaces an element with a new element of a certain class
+ ! and sets the old element as a child of the new one
+ dup call new replace-element swap add-element ;
+
+:: exchange-node-side ( node side -- node )
+ ! exchanges a node and the node the left/right
+ node parent>> [ vocab? ] [ [ [ class-of ] sort-with ] change-contents ] smart-when
+ contents>> :> nodes
+ node nodes index dup side left eq? -1 1 ? +
+ nodes length 1 - min 0 max nodes exchange node ;
+
+: top-node? ( node -- ? )
+ ! tells if the node has no children
+ contents>> empty? ;
+
+: bottom-node? ( node -- ? )
+ ! tells if the node has no parent
+ parent>> node? not ;
+
+: leftmost-node? ( node -- ? )
+ ! tells if a node has no brother on the left
+ dup parent>> contents>> index 0 = ;
+
+: rightmost-node? ( node -- ? )
+ ! tells if a node has no brother on the right
+ dup parent>> contents>> [ index ] keep length 1 - = ;
+
+: middle-node? ( node -- ? )
+ ! tells if a node has a parent and has children
+ [ top-node? ] [ bottom-node? ] bi or not ;
+
+: parent-node ( node -- node )
+ ! returns the parent of the node, or the same node if the parent is a "word"
+ [ parent>> dup word? not and ] [ parent>> ] smart-when ;
+
+: child-node ( node -- node )
+ ! returns the first child of the node, or the same node if it has no children
+ [ contents>> empty? ] [ contents>> first ] smart-unless ;
+
+:: side-node ( node side -- node )
+ ! returns the brother node on the left/right,
+ ! or the same node if there is nothing to the left/right
+ node parent>> contents>> :> nodes
+ node nodes index 1 side left eq? [ - ] [ + ] if nodes ?nth [ node ] unless* ;
+
+:: change-nodes-above ( elt names -- )
+ elt arity :> old-n
+ names length :> n
+ elt {
+ { [ n old-n > ] [ n old-n - [ call add-from-class ] times drop ] }
+! { [ n old-n < ] [ contents>> n swap shorten ] }
+ [ drop ]
+ } cond
+ names elt contents>> [ default-name<< ] 2each ;
+
+:: change-node-type ( node class -- new-node )
+ ! replaces a node by a node of a different type that has the same name and contents
+ node class new node name>> >>name node quoted?>> >>quoted?
+ node contents>> [ add-element ] each replace-element ;
+
+: no-return? ( node -- ? )
+ ! tells if the word that contains the node has no "return" child
+ [ word? ] find-parent returns empty? ;
+
+: ?change-node-type ( node class -- new-node )
+ ! replaces a node by a node of a different type that has the same name and contents
+ ! only if certain conditions are met
+ 2dup {
+ { introduce [ top-node? ] }
+ { text [ top-node? ] }
+ { getter [ top-node? ] }
+ { return [ [ bottom-node? ] [ no-return? ] bi and ] }
+ { setter [ bottom-node? ] }
+ [ drop drop t ]
+ } case [ change-node-type ] [ drop ] if ;
+
+: name-or-default ( elt -- str )
+ ! returns the name of the element, or its default name, or its class
+ { { [ dup name>> empty? not ] [ name>> ] }
+ { [ dup default-name>> empty? not ] [ default-name>> ] }
+ { [ dup introduce? ] [ drop "input" ] }
+ { [ dup return? ] [ drop "output" ] }
+ { [ dup call? ] [ drop "word" ] }
+ { [ dup vocab? ] [ drop "vocabulary" ] }
+ { [ dup getter? ] [ drop "get" ] }
+ { [ dup setter? ] [ drop "set" ] }
+ [ class-of unparse ] } cond >string ;
+
+CONSTANT: special-words { "while" "until" "if" "times" "produce" }
+GENERIC: factor-name ( elt -- str )
+
+M: element factor-name
+ name>> ;
+
+M: call factor-name
+ name>> dup special-words member? [ "special " prepend ] when ;
+
+GENERIC: path ( elt -- str )
+
+M: vocab path
+ parents reverse rest [ factor-name ] map "." join [ "scratchpad" ] when-empty ;
+
+M: word path
+ parents reverse rest but-last [ factor-name ] map "." join [ "scratchpad" ] when-empty ;
+
+M: call path
+ target>> [ words:word? ] [ vocabulary>> ] [ drop f ] smart-if ;
+
+M: node path
+ drop f ;
+
+: replace-quot ( seq -- seq )
+ [ array? ] [ first [ "quot" swap subseq? not ] [ " quot" append ] smart-when ] smart-when ;
+
+: convert-stack-effect ( stack-effect -- seq seq )
+ ! converts a stack effect into two sequences of input and output names
+ [ in>> ] [ out>> ] bi [ [ replace-quot ] map ] bi@ ;
+
+: same-name-as-parent? ( call -- ? )
+ ! tells if a call has the same name as its parent
+ dup [ word? ] find-parent [ name>> ] bi@ = ;
+
+: input-output-names ( word -- seq seq )
+ ! returns two sequences containing the input and output names of a word
+ [ introduces ] [ returns ] bi [ [ name>> ] map sift members ] bi@ ;
+
+SINGLETON: recursion
+
+GENERIC: (in-out) ( elt -- seq seq )
+
+M: source (in-out)
+ drop f { "" } ;
+
+M: sink (in-out)
+ drop { "" } f ;
+
+M:: call (in-out) ( call -- seq seq )
+ call target>>
+ { { [ dup recursion? ] [ drop call [ word? ] find-parent input-output-names ] }
+ { [ dup number? ] [ drop { } { "" } ] }
+ { [ dup not ] [ drop { } { } ] }
+ [ "declared-effect" words:word-prop convert-stack-effect ]
+ } cond ;
+
+CONSTANT: sequence-variadic-words { "array" } ! "sequence" "each" "map" "append" "produce" }
+CONSTANT: special-variadic-words { "call" }
+
+: simple-variadic? ( call -- ? )
+ (in-out) { [ drop length 2 = ] [ nip length 1 = ]
+ [ first swap first2 dupd = -rot = and ] } 2&& ;
+
+: comparison-variadic? ( call -- ? )
+ (in-out) [ length 2 = ] [ ?first "?" = ] bi* and ;
+
+: sequence-variadic? ( call -- ? )
+ name>> sequence-variadic-words member? ;
+
+: special-variadic? ( call -- ? )
+ name>> special-variadic-words member? ;
+
+: variadic? ( call -- ? )
+ { [ simple-variadic? ] [ comparison-variadic? ]
+ [ sequence-variadic? ] [ special-variadic? ] } cleave or or or ;
+
+:: insert-node-side ( node side -- new-node )
+ ! inserts a new "call" to the left/right of a node
+ node dup parent>> { [ word? ] [ variadic? ] } 1||
+ [ parent>> contents>> :> nodes
+ call new node parent>> >>parent dup :> new-node
+ node nodes index side right eq? [ 1 + ] when
+ nodes insert-nth! new-node ] when ;
+
+:: in-out ( elt -- seq seq )
+ { { [ elt call? not ] [ elt (in-out) ] }
+ { [ elt simple-variadic? ]
+ [ elt (in-out) [ first [ ] curry elt arity 2 max swap replicate ] dip ] }
+ { [ elt sequence-variadic? ]
+ [ elt arity 1 max [ "x" ] replicate { "seq" } ] }
+ { [ elt name>> "call" = ]
+ [ f elt arity 1 - [ "x" suffix ] times "quot" suffix { "result" } ] }
+ [ elt (in-out) ]
+ } cond ;
+
+: short-name ( str -- str )
+ " (constructor)" " (accessor)" " (mutator)" [ "" replace ] tri@ ;
+
+:: matching-words ( str -- seq )
+ ! returns all Factor words whose name begins with a certain string
+ interactive-vocabs get [ vocabs:vocab-words ] map concat [ name>> str head? ] filter ;
+
+:: matching-words-exact ( str -- seq )
+ ! returns all Factor words that have a certain name
+ interactive-vocabs get [ vocabs:vocab-words ] map concat [ name>> short-name str = ] filter ;
+
+:: find-target ( call -- seq )
+ ! returns the Factor word that has the same name as the call
+ call factor-name :> name
+ { { [ call same-name-as-parent? ] [ recursion 1array ] }
+ { [ name string>number ] [ name string>number 1array ] }
+ [ name matching-words-exact ]
+ } cond ;
+
+: (un)quote ( node -- node )
+ ! toggles the "quoted?" attribute of a node
+ [ not ] change-quoted? ;
+
+:: ?add-words-above ( elt -- )
+ elt elt in-out drop change-nodes-above
+ elt contents>> [ ?add-words-above ] each ;
+
+:: ?add-word-below ( elt -- )
+ elt in-out nip [ first elt insert-new-parent default-name<< ] unless-empty ;
+
+:: ?add-words ( word -- word )
+ word contents>>
+ [ word call add-from-class drop ]
+ [ [ dup ?add-word-below ?add-words-above ] each ]
+ if-empty word ;
+
+: any-empty-name? ( word -- ? )
+ ! tells if there are any empty names in the child tree of a word
+ sort-tree
+ [ [ introduce? ] [ [ quoted-node? ] find-parent ] bi and ] reject
+ [ name>> empty? ] any? ;
+
+: executable? ( word -- ? )
+ ! tells if a word has the right properties to be executable
+ { [ word? ]
+ [ introduces [ [ quoted-node? ] find-parent ] reject empty? ]
+ [ returns empty? ]
+ [ calls empty? not ]
+ [ any-empty-name? not ]
+ [ defined?>> ]
+ } 1&& ;
+
+: error? ( word -- ? )
+ ! tells if a word contains any error
+ { [ defined?>> not ]
+ [ any-empty-name? ]
+ [ contents>> empty? ]
+ } 1|| ;
+
+: save-result ( str word -- )
+ ! stores a string as the result of a word
+ swap dupd result new swap >>contents swap >>parent >>result drop ;
--- /dev/null
+! Copyright (C) 2015-2016 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes.parser classes.tuple code
+combinators combinators.smart compiler.units debugger effects io
+io.streams.string kernel listener locals locals.rewrite
+locals.types math math.statistics namespaces quotations
+sequences sequences.deep sets splitting ui.gadgets.panes
+vocabs.parser ;
+FROM: code => call ;
+QUALIFIED: words
+QUALIFIED: vocabs
+IN: code.execution
+
+: effect ( def -- effect )
+ [ introduces [ name>> empty? ] reject ] [ returns ] bi
+ [ [ factor-name ] map members >array ] bi@ <effect> ;
+
+: set-ids ( seq -- )
+ [ name>> ] collect-by [
+ [ drop empty? ]
+ [ [ "x" <local> >>id ] map 2drop ]
+ [ [ <local> ] dip [ id<< ] with each ] smart-if
+ ] assoc-each ;
+
+: set-input-ids ( word -- word )
+ dup introduces set-ids ;
+
+: set-link-ids ( word -- word )
+ dup links set-ids ;
+
+:: process-simple-variadic ( call -- seq )
+ call arity 1 - [ call target>> ] replicate ;
+
+:: process-comparison-variadic ( call -- seq )
+ call arity 2 = [ call target>> 1array ]
+ [ \ dupd call target>> \ -rot 3array
+ call arity 3 -
+ [ \ dupd suffix call target>> suffix \ swapd suffix \ and suffix \ -rot suffix ] times
+ call target>> suffix \ and suffix ] if ;
+
+:: process-sequence-variadic ( call -- seq )
+ call arity
+ call name>> "1" ?head drop CHAR: n prefix [ search ] with-interactive-vocabs
+ 2array ;
+
+: process-quotation-call ( call -- seq )
+ arity 1 - [ "x" ] replicate "o" 1array <effect> \ call-effect 2array ;
+
+: process-variadic ( call -- word/seq )
+ { { [ dup name>> "call" = ] [ process-quotation-call ] }
+ { [ dup simple-variadic? ] [ process-simple-variadic ] }
+ { [ dup comparison-variadic? ] [ process-comparison-variadic ] }
+ { [ dup sequence-variadic? ] [ process-sequence-variadic ] }
+ [ target>> ]
+ } cond ;
+
+GENERIC: transform ( node -- compiler-node )
+
+:: transform-quotation ( node -- compiler-node )
+ node transform node quoted-node?
+ [ node own-introduces [ name>> empty? ] filter [ transform ] map
+ swap flatten >quotation <lambda> ] when ;
+
+M: introduce transform
+ id>> ;
+
+M: text transform
+ name>> ;
+
+M: getter transform
+ id>> ;
+
+M: setter transform
+ [ contents>> [ transform-quotation ] map ] [ id>> <def> ] bi 2array ;
+
+M: call transform
+ [ contents>> [ transform-quotation ] map ] [ process-variadic ] bi 2array ;
+
+M: return transform
+ contents>> [ transform-quotation ] map ;
+
+M: word transform
+ set-input-ids set-link-ids
+ [ introduces [ name>> empty? ] reject [ transform ] map members ]
+ [ contents>> [ transform-quotation ] map flatten >quotation ] bi <lambda> ;
+
+:: set-recursion ( word lambda -- lambda )
+ lambda [ recursion 1array word 1array replace
+ dup [ lambda? ] filter [ word swap set-recursion ] map drop ] change-body ;
+
+:: try-definition ( quot def -- )
+ [ def f >>defined? quot with-compilation-unit t >>defined? drop ] try ; inline
+
+: interactive? ( vocab-name -- ? )
+ interactive-vocabs get-global member? ;
+
+: add-interactive-vocab ( vocab-name -- )
+ [ interactive? not ]
+ [ interactive-vocabs [ swap suffix ] change-global ] smart-when* ;
+
+: remove-interactive-vocab ( vocab-name -- )
+ interactive-vocabs [ remove ] change-global ;
+
+GENERIC: define ( def -- )
+
+M:: vocab define ( def -- )
+ def path [ vocabs:create-vocab def target<< ] [ add-interactive-vocab ] bi ;
+
+M:: word define ( def -- )
+ [ def factor-name
+ def path words:create-word dup dup def target<<
+ def transform set-recursion rewrite-closures first
+ def effect words:define-declared
+ ] def try-definition ;
+
+: ?define ( elt -- )
+ [ name>> ] [ define ] smart-when* ;
+
+: run-word ( word -- )
+ [ ?define ]
+ [ target>> f pane new-pane dup swapd <pane-stream> [ execute( -- ) ] with-output-stream ]
+ [ save-result ] tri ;
--- /dev/null
+! Copyright (C) 2016-2017 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors code combinators combinators.smart effects
+kernel locals math math.parser quotations sequences splitting
+stack-checker strings vectors words ;
+FROM: code => call word ;
+IN: code.factor-abstraction
+
+:: call-from-factor ( factor-word -- call )
+ call new factor-word name>> >>name factor-word >>target ;
+
+: make-tree ( nodes -- tree )
+ dup [ introduce new ] [ pop ] if-empty dup
+ [ quoted-node? ] [ drop 0 ] [ in-out drop length ] smart-if
+ swapd [ dup make-tree ] replicate reverse nip [ add-element ] each ;
+
+: node-from-factor ( factor-word -- node )
+ { { [ dup words:word? ] [ call-from-factor ] }
+ { [ dup string? ] [ text new >>name ] }
+ { [ dup number? ] [ call new swap [ number>string >>name ] keep >>target ] }
+ { [ dup quotation? ] [ [ node-from-factor ] map >vector make-tree t >>quoted? ] }
+ } cond ;
+
+:: word-from-factor ( factor-word -- word )
+ factor-word stack-effect
+ [ in>> [ introduce new swap >>name ] map ]
+ [ out>> [ return new swap >>name ] map ] bi
+ factor-word def>> [ node-from-factor ] map
+ swap 3append >vector make-tree
+ word new swap add-element ;
--- /dev/null
+! Copyright (C) 2016 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays classes combinators combinators.smart
+eval io io.directories io.encodings.utf8 io.files io.files.info
+io.pathnames kernel locals math namespaces prettyprint prettyprint.config
+sequences code system ui.gadgets code.execution ;
+FROM: code => call ;
+IN: code.import-export
+
+SYMBOL: skov-version
+
+: work-directory ( -- path )
+ image-path parent-directory "work" append-path ;
+
+: make-directory? ( path -- path )
+ [ file-exists? not ] [ dup make-directory ] smart-when ;
+
+: vocab-directory-path ( elt -- str )
+ parents reverse rest [ factor-name ] map path-separator join work-directory swap append-path ;
+
+GENERIC: (export) ( element -- seq )
+
+: export ( element -- seq )
+ [ (export) ] [ name>> prefix ] [ class-of prefix ] tri ;
+
+M: element (export)
+ contents>> [ export ] map >array 1array ;
+
+M: vocab (export)
+ words [ export ] map >array 1array ;
+
+M: node (export)
+ [ quoted?>> ] [ contents>> [ export ] map >array ] bi 2array ;
+
+M: call (export)
+ [ path ] [ quoted?>> ] [ contents>> [ export ] map >array ] tri 3array ;
+
+:: write-vocab-file ( vocab -- )
+ vocab vocab-directory-path make-directory?
+ vocab factor-name ".skov" append append-path utf8
+ [ "! Skov version " skov-version get-global append print vocab export [ . ] without-limits ] with-file-writer
+ vocab vocabs [ write-vocab-file ] each ;
+
+: export-vocabs ( -- )
+ skov-root get-global write-vocab-file ;
+
+:: find-target-with-path ( call -- )
+ call target>> :> this-path
+ call dup find-target
+ [ [ number? not ] [ vocabulary>> this-path = ] [ t ] smart-if* ] filter
+ ?first >>target drop ;
+
+: find-targets ( def -- )
+ calls [ find-target-with-path ] each ;
+
+: define-all-words ( vocab -- )
+ [ ?define ]
+ [ vocabs [ define-all-words ] each ]
+ [ words [ [ find-targets ] [ ?define ] bi ] each ] tri ;
+
+GENERIC: (import) ( seq element -- element )
+
+: import ( seq -- element )
+ unclip new swap unclip swapd >>name (import) ;
+
+M: element (import)
+ swap first [ import add-element ] each ;
+
+M: node (import)
+ swap first2 [ >>quoted? ] [ [ import add-element ] each ] bi* ;
+
+M: call (import)
+ swap first3 [ >>target ] [ >>quoted? ] [ [ import add-element ] each ] tri* ;
+
+: sub-directories ( path -- seq )
+ dup directory-entries [ directory? ] filter [ name>> append-path ] with map ;
+
+: any-vocab-files? ( path -- ? )
+ directory-files [ file-extension "skov" = ] filter empty? not ;
+
+: skov-file ( path -- path )
+ dup directory-files [ file-extension "skov" = ] filter first append-path ;
+
+:: read-vocab-files ( path -- vocab )
+ path skov-file utf8 file-contents "USE: code " swap append eval( -- seq ) import
+ path sub-directories [ read-vocab-files add-element ] each ;
+
+: update-skov-root ( -- )
+ skov-root work-directory [ any-vocab-files? ]
+ [ read-vocab-files dup define-all-words swap set-global ] [ drop ] smart-if* ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2009 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel colors ;
+IN: fonts
+
+HELP: <font>
+{ $values { "font" font } }
+{ $description "Creates a new font." } ;
+
+HELP: font
+{ $class-description "The class of fonts." } ;
+
+HELP: font-with-background
+{ $values
+ { "font" font } { "color" color }
+ { "font'" font }
+}
+{ $description "Creates a new font equal to the given font, except with a different " { $slot "background" } " slot." } ;
+
+HELP: font-with-foreground
+{ $values
+ { "font" font } { "color" color }
+ { "font'" font }
+}
+{ $description "Creates a new font equal to the given font, except with a different " { $slot "foreground" } " slot." } ;
+
+ARTICLE: "fonts" "Fonts"
+"The " { $vocab-link "fonts" } " vocabulary implements a data type for fonts that other vocabularies, for example " { $link "ui" } ", can use. A font combines a font name, size, style, and color information into a single object."
+{ $subsections
+ font
+ <font>
+}
+"Modifying fonts:"
+{ $subsections
+ font-with-foreground
+ font-with-background
+}
+"Useful constants:"
+{ $subsections
+ monospace-font
+ sans-serif-font
+ serif-font
+}
+"A data type for font metrics. The " { $vocab-link "fonts" } " vocabulary does not provide any means of computing font metrics, it simply defines a common data type that other vocabularies, such as " { $vocab-link "ui.text" } " may use:"
+{ $subsections metrics } ;
+
+ABOUT: "fonts"
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors colors combinators kernel math namespaces ;
+IN: fonts
+
+CONSTANT: default-serif-font-name "serif"
+CONSTANT: default-sans-serif-font-name "Linux Biolinum O" inline
+CONSTANT: default-monospace-font-name "Linux Biolinum O" inline
+
+CONSTANT: default-font-size 15
+
+SYMBOL: default-font-foreground-color
+COLOR: black default-font-foreground-color set-global
+
+SYMBOL: default-font-background-color
+COLOR: white default-font-background-color set-global
+
+TUPLE: font name size bold? italic? foreground background ;
+
+: <font> ( -- font )
+ font new
+ default-font-foreground-color get >>foreground
+ default-font-background-color get >>background ; inline
+
+: font-with-foreground ( font color -- font' )
+ [ clone ] dip >>foreground ; inline
+
+: font-with-background ( font color -- font' )
+ [ clone ] dip >>background ; inline
+
+: font-with-size ( font size -- font' )
+ [ clone ] dip >>size ; inline
+
+: reverse-video-font ( font -- font )
+ clone dup
+ [ foreground>> >>background ]
+ [ background>> >>foreground ] bi ;
+
+: derive-font ( base font -- font' )
+ [
+ [ clone ] dip over {
+ [ [ name>> ] either? >>name ]
+ [ [ size>> ] either? >>size ]
+ [ [ bold?>> ] either? >>bold? ]
+ [ [ italic?>> ] either? >>italic? ]
+ [ [ foreground>> ] either? >>foreground ]
+ [ [ background>> ] either? >>background ]
+ } 2cleave
+ ] when* ;
+
+: serif-font ( -- font )
+ <font>
+ default-serif-font-name >>name
+ default-font-size >>size ;
+
+: sans-serif-font ( -- font )
+ <font>
+ default-sans-serif-font-name >>name
+ default-font-size >>size ;
+
+: monospace-font ( -- font )
+ <font>
+ default-monospace-font-name >>name
+ default-font-size >>size ;
+
+: strip-font-colors ( font -- font' )
+ clone f >>background f >>foreground ;
+
+TUPLE: metrics width ascent descent height leading cap-height x-height ;
+
+: compute-height ( metrics -- metrics )
+ dup [ ascent>> ] [ descent>> ] bi + >>height ; inline
+
+TUPLE: selection string start end color ;
+
+C: <selection> selection
+
--- /dev/null
+Fonts as a first-class data type
--- /dev/null
+USING: arrays help.crossref help.lint help.markup
+help.stylesheet help.syntax help.topics io kernel math
+prettyprint quotations see sequences strings summary vocabs ;
+IN: help
+
+ARTICLE: "printing-elements" "Printing markup elements"
+"When writing documentation, it is useful to be able to print markup elements for testing purposes. Markup elements which are strings or arrays of elements are printed in the obvious way. Markup elements of the form " { $snippet "{ $directive content... }" } " are printed by executing the " { $snippet "$directive" } " word with the element content on the stack."
+{ $subsections
+ print-element
+ print-content
+} ;
+
+ARTICLE: "span-elements" "Span elements"
+{ $subsections
+ $emphasis
+ $strong
+ $link
+ $vocab-link
+ $snippet
+ $slot
+ $url
+} ;
+
+ARTICLE: "block-elements" "Block elements"
+"Paragraph break:"
+{ $subsections $nl }
+"Standard headings for word documentation:"
+{ $subsections
+ $values
+ $description
+ $class-description
+ $error-description
+ $var-description
+ $contract
+ $examples
+ $warning
+ $notes
+ $side-effects
+ $errors
+ $see-also
+}
+"Elements used in " { $link $values } " forms:"
+{ $subsections
+ $instance
+ $maybe
+ $or
+ $quotation
+ $sequence
+}
+"Boilerplate paragraphs:"
+{ $subsections
+ $low-level-note
+ $io-error
+}
+"Some additional elements:"
+{ $subsections
+ $code
+ $curious
+ $example
+ $heading
+ $links
+ $list
+ $markup-example
+ $references
+ $see
+ $subsection
+ $table
+} ;
+
+ARTICLE: "markup-utils" "Markup element utilities"
+"Utility words to assist in defining new elements:"
+{ $subsections
+ simple-element
+ ($span)
+ ($block)
+} ;
+
+ARTICLE: "element-types" "Element types"
+"Markup elements can be classified into two broad categories, block elements and span elements. Block elements are inset with newlines before and after, whereas span elements flow with the paragraph text."
+{ $subsections
+ "span-elements"
+ "block-elements"
+ "markup-utils"
+} ;
+
+IN: help.markup
+ABOUT: "element-types"
+
+ARTICLE: "writing-help" "Writing documentation"
+"By convention, documentation is written in files whose names end with " { $snippet "-docs.factor" } ". Vocabulary documentation should be placed in the same directory as the vocabulary source code; see " { $link "vocabs.loader" } "."
+$nl
+"A pair of parsing words are used to define free-standing articles and to associate documentation with words:"
+{ $subsections
+ POSTPONE: ARTICLE:
+ POSTPONE: HELP:
+}
+"A parsing word defines the main help article for a vocabulary:"
+{ $subsections POSTPONE: ABOUT: }
+"The " { $emphasis "content" } " in both cases is a " { $emphasis "markup element" } ", a recursive structure taking one of the following forms:"
+{ $list
+ { "a string," }
+ { "an array of markup elements," }
+ { "or an array of the form " { $snippet "{ $directive content... }" } ", where " { $snippet "$directive" } " is a markup word whose name starts with " { $snippet "$" } ", and " { $snippet "content..." } " is a series of markup elements" }
+}
+"Here is a more formal schema for the help markup language:"
+{ $code
+"<element> ::== <string> | <simple-element> | <fancy-element>"
+"<simple-element> ::== { <element>* }"
+"<fancy-element> ::== { <type> <element> }"
+}
+{ $subsections
+ "element-types"
+ "printing-elements"
+}
+"Related words can be cross-referenced:"
+{ $subsections related-words }
+{ $see-also "help.lint" } ;
+
+ARTICLE: "help-impl" "Help system implementation"
+"Help topic protocol:"
+{ $subsections
+ article-name
+ article-title
+ article-content
+ article-parent
+ set-article-parent
+}
+"Boilerplate word help can be automatically generated (for example, slot accessor help):"
+{ $subsections
+ word-help
+ word-help*
+}
+"Help article implementation:"
+{ $subsections
+ lookup-article
+ articles
+}
+"Links:"
+{ $subsections
+ link
+ >link
+}
+"Utilities for traversing markup element trees:"
+{ $subsections
+ elements
+ collect-elements
+}
+"Links and " { $link article } " instances implement the definition protocol; refer to " { $link "definitions" } "." ;
+
+ARTICLE: "help" "Help system"
+"The help system maintains documentation written in a simple markup language, along with cross-referencing and search. Documentation can either exist as free-standing " { $emphasis "articles" } " or be associated with words."
+{ $subsections
+ "browsing-help"
+ "writing-help"
+ "help.lint"
+ "tips-of-the-day"
+ "help-impl"
+} ;
+
+IN: help
+ABOUT: "help"
+
+HELP: $title
+{ $values { "topic" "a help article name or a word" } }
+{ $description "Prints a help article's title, or a word's " { $link summary } ", depending on the type of " { $snippet "topic" } "." } ;
+
+HELP: print-topic
+{ $values { "topic" "an article name or a word" } }
+{ $description
+ "Displays a help topic on " { $link output-stream } "."
+} ;
+
+HELP: help
+{ $values { "topic" "an article name or a word" } }
+{ $description
+ "Displays a help topic."
+} ;
+
+HELP: :help
+{ $description "Displays documentation for the most recent error." } ;
+
+HELP: $subsection
+{ $values { "element" "a markup element of the form " { $snippet "{ topic }" } } }
+{ $description "Prints a large clickable link to the help topic named by the first item in " { $snippet "element" } ". The link is printed along with its associated definition icon." }
+{ $examples
+ { $markup-example { $subsection "sequences" } }
+ { $markup-example { $subsection nth } }
+ { $markup-example { $subsection each } }
+} ;
+
+HELP: $subsections
+{ $values { "children" "a " { $link sequence } " of one or more " { $link topic } "s or, in the case of a help article, the article's string name." } }
+{ $description "Prints a large clickable link for each of the listed help topics in " { $snippet "children" } ". The link is printed along with its associated definition icon." }
+{ $examples
+ { $markup-example { $subsections "sequences" nth each } }
+} ;
+
+{ $subsection $subsections $link } related-words
+
+HELP: $vocab-subsection
+{ $values { "element" "a markup element of the form " { $snippet "{ title vocab }" } } }
+{ $description "Prints a large clickable link for " { $snippet "vocab" } ". If " { $snippet "vocab" } " has a main help article, the link will point at that article and the " { $snippet "title" } " input will be ignored. Otherwise, the link text will be taken from " { $snippet "title" } " and point to " { $snippet "vocab" } "'s automatically generated documentation."
+$nl
+"The link will be printed along with its associated definition icon." }
+{ $examples
+ { $markup-example { $vocab-subsection "SQLite" "db.sqlite" } }
+ { $markup-example { $vocab-subsection "Alien" "alien" } }
+} ;
+
+HELP: $index
+{ $values { "element" "a markup element containing one quotation with stack effect " { $snippet "( quot -- )" } } }
+{ $description "Calls the quotation to generate a sequence of help topics, and outputs a " { $link $subsection } " for each one." } ;
+
+HELP: ($index)
+{ $values { "articles" "a sequence of help articles" } }
+{ $description "Writes a list of " { $link $subsection } " elements to " { $link output-stream } "." } ;
+
+HELP: xref-help
+{ $description "Update help cross-referencing. Usually this is done automatically." } ;
+
+HELP: sort-articles
+{ $values { "seq" "a sequence of help topics" } { "newseq" "a sequence of help topics" } }
+{ $description "Sorts a sequence of help topics." } ;
+
+{ article-children article-parent xref-help } related-words
+
+HELP: $predicate
+{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }
+{ $description "Prints the boilerplate description of a class membership predicate word such as " { $link array? } " or " { $link integer? } "." } ;
+
+HELP: print-element
+{ $values { "element" "a markup element" } }
+{ $description "Prints a markup element to " { $link output-stream } "." } ;
+
+HELP: print-content
+{ $values { "element" "a markup element" } }
+{ $description "Prints a top-level markup element to " { $link output-stream } "." } ;
+
+HELP: simple-element
+{ $class-description "Class of simple elements, which are just arrays of elements." } ;
+
+HELP: ($span)
+{ $values { "quot" quotation } }
+{ $description "Prints an inline markup element." } ;
+
+HELP: ($block)
+{ $values { "quot" quotation } }
+{ $description "Prints a block markup element with newlines before and after." } ;
+
+HELP: $heading
+{ $values { "element" "a markup element" } }
+{ $description "Prints a markup element, usually a string, as a block with the " { $link heading-style } "." }
+{ $examples
+ { $markup-example { $heading "What remains to be discovered" } }
+} ;
+
+HELP: $subheading
+{ $values { "element" "a markup element of the form " { $snippet "{ title content }" } } }
+{ $description "Prints a markup element, usually a string, as a block with the " { $link strong-style } "." }
+{ $examples
+ { $markup-example { $subheading "Developers, developers, developers!" } }
+} ;
+
+HELP: $code
+{ $values { "element" "a markup element of the form " { $snippet "{ string... }" } } }
+{ $description "Prints code examples, as seen in many help articles. The markup element must be an array of strings." }
+{ $notes
+ "The code becomes clickable if the output stream supports it, and clicking it opens a listener window with the text inserted at the input prompt."
+ $nl
+ "If you want to show code along with sample output, use the " { $link $example } " element."
+}
+{ $examples
+ { $markup-example { $code "2 2 + ." } }
+} ;
+
+HELP: $nl
+{ $values { "children" "unused parameter" } }
+{ $description "Prints a paragraph break. The parameter is unused." } ;
+
+HELP: $snippet
+{ $values { "children" "markup elements" } }
+{ $description "Prints a key word or otherwise notable snippet of text, such as a type or a word input parameter. To document slot names, use " { $link $slot } "." }
+{ $examples
+ { $markup-example { $snippet "vocab" } }
+ { $markup-example { $snippet "{ string... }" } }
+} ;
+
+HELP: $slot
+{ $values { "children" "markup elements" } }
+{ $description "Prints a tuple slot name in the same way as a snippet. The help tool can check that there exists an accessor with this name." } ;
+
+HELP: $vocabulary
+{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }
+{ $description "Prints a word's vocabulary. This markup element is automatically output by the help system, so help descriptions of parsing words should not call it." } ;
+
+HELP: $description
+{ $values { "element" "a markup element" } }
+{ $description "Prints the description subheading found on the help page of most words." } ;
+
+HELP: $contract
+{ $values { "element" "a markup element" } }
+{ $description "Prints a heading followed by a contract, found on the help page of generic words. Every generic word should document a contract which specifies method behavior that callers can rely upon, and implementations must obey." }
+{ $examples
+ { $markup-example { $contract "Methods of this generic word must always crash." } }
+} ;
+
+HELP: $examples
+{ $values { "element" "a markup element" } }
+{ $description "Prints a heading followed by some examples. Word documentation should include examples, at least if the usage of the word is not entirely obvious." }
+{ $examples
+ { $markup-example { $examples { $example "USING: math prettyprint ;" "2 2 + ." "4" } } }
+} ;
+
+HELP: $example
+{ $values { "element" "a markup element of the form " { $snippet "{ inputs... output }" } } }
+{ $description "Prints a clickable example with sample output. The markup element must be an array of strings. All but the last string are joined by newlines and taken as the input text, and the last string is the output. The example becomes clickable if the output stream supports it, and clicking it opens a listener window with the input text inserted at the input prompt." }
+{ $examples
+ "The input text must contain a correct " { $link POSTPONE: USING: } " declaration, and output text should be a string of what the input prints when executed, not the final stack contents or anything like that. So the following is an incorrect example:"
+ { $markup-example { $unchecked-example "2 2 +" "4" } }
+ "However the following is right:"
+ { $markup-example { $example "USING: math prettyprint ;" "2 2 + ." "4" } }
+ "Examples can incorporate a call to " { $link .s } " to show multiple output values; the convention is that you may assume the stack is empty before the example evaluates."
+}
+{ $see-also $unchecked-example } ;
+
+HELP: $unchecked-example
+{ $values { "element" object } }
+{ $description "Same as " { $link $example } ", except " { $link help-lint } " ignores its contents and doesn't try to run the code and verify its output." } ;
+
+HELP: $markup-example
+{ $values { "element" "a markup element" } }
+{ $description "Prints a clickable example showing the prettyprinted source text of " { $snippet "element" } " followed by rendered output. The example becomes clickable if the output stream supports it." }
+{ $examples
+ { $markup-example { $markup-example { $emphasis "Hi" } } }
+} ;
+
+HELP: $warning
+{ $values { "element" "a markup element" } }
+{ $description "Prints an element inset in a block styled as so to draw the reader's attention towards it." }
+{ $examples
+ { $markup-example { $warning "Incorrect use of this product may cause serious injury or death." } }
+} ;
+
+HELP: $link
+{ $values { "element" "a markup element of the form " { $snippet "{ topic }" } } }
+{ $description "Prints a link to a help article or word." }
+{ $examples
+ { $markup-example { $link "dlists" } }
+ { $markup-example { $link + } }
+} ;
+
+HELP: textual-list
+{ $values { "seq" sequence } { "quot" { $quotation ( elt -- ) } } }
+{ $description "Applies the quotation to each element of the sequence, printing a comma between each pair of elements." }
+{ $examples
+ { $example "USING: help.markup io namespaces ;" "last-element off" "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list" "fish, chips, salt" }
+} ;
+
+HELP: $links
+{ $values { "topics" "a sequence of article names or words" } }
+{ $description "Prints a series of links to help articles or word documentation." }
+{ $notes "This markup element is used to implement " { $link $links } "." }
+{ $examples
+ { $markup-example { $links + - * / } }
+} ;
+
+HELP: $see-also
+{ $values { "topics" "a sequence of article names or words" } }
+{ $description "Prints a heading followed by a series of links." }
+{ $examples
+ { $markup-example { $see-also "graphs" "dlists" } }
+} ;
+
+{ $see-also $related related-words } related-words
+
+HELP: $table
+{ $values { "element" "an array of arrays of markup elements" } }
+{ $description "Prints a table given as an array of rows, where each row must have the same number of columns." }
+{ $examples
+ { $markup-example
+ { $table
+ { "a" "b" "c" }
+ { "d" "e" "f" }
+ }
+ }
+} ;
+
+HELP: $values
+{ $values { "element" "an array of pairs of markup elements" } }
+{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder is either a single class word, or an element. If it is a class word " { $snippet "class" } ", it is inserted as if it were shorthand for " { $snippet "{ $instance class }" } "." }
+{ $see-also $maybe $instance $quotation }
+{ $examples
+ { $markup-example { $values { "arg1" "description of arg1" } { "arg2" integer } } }
+}
+$nl ;
+
+HELP: $instance
+{ $values { "element" "an array with shape " { $snippet "{ class }" } } }
+{ $description
+ "Produces the text “a " { $emphasis "class" } "” or “an " { $emphasis "class" } "”, depending on the first letter of " { $emphasis "class" } "."
+}
+{ $examples
+ { $markup-example { $instance string } }
+ { $markup-example { $instance integer } }
+ { $markup-example { $instance f } }
+} ;
+
+HELP: $maybe
+{ $values { "element" "an array with shape " { $snippet "{ class }" } } }
+{ $description
+ "Produces the text “a " { $emphasis "class" } " or f” or “an " { $emphasis "class" } " or f”, depending on the first letter of " { $emphasis "class" } "."
+}
+{ $examples
+ { $markup-example { $maybe string } }
+} ;
+
+HELP: $quotation
+{ $values { "element" "an array with shape " { $snippet "{ effect }" } } }
+{ $description
+ "Produces the text “a quotation with stack effect " { $emphasis "effect" } "”."
+}
+{ $examples
+ { $markup-example { $quotation ( obj -- ) } }
+} ;
+
+HELP: $sequence
+{ $values { "element" "an array of element types" } }
+{ $description
+ "Produces the text “a sequence of " { $emphasis "element types" } "”."
+}
+{ $examples
+ { $markup-example { $sequence number } }
+ { $markup-example { $sequence real complex } }
+ { $markup-example { $sequence rational float complex } }
+ { $markup-example { $sequence integer ratio float complex } }
+ { $markup-example { $sequence fixnum bignum ratio float complex } }
+} ;
+
+HELP: $list
+{ $values { "element" "an array of markup elements" } }
+{ $description "Prints a bulleted list of markup elements." }
+{ $notes
+ "A common mistake is that if an item consists of more than just a string, it will be broken up as several items:"
+ { $markup-example
+ { $list
+ "First item"
+ "Second item " { $emphasis "with emphasis" }
+ }
+ }
+ "The fix is easy; just group the two markup elements making up the second item into one markup element:"
+ { $markup-example
+ { $list
+ "First item"
+ { "Second item " { $emphasis "with emphasis" } }
+ }
+ }
+} ;
+
+HELP: $errors
+{ $values { "element" "a markup element" } }
+{ $description "Prints the errors subheading found on the help page of some words. This section should document any errors thrown by the word." }
+{ $examples
+ { $markup-example { $errors "I/O errors, network errors, hardware errors... oh my!" } }
+} ;
+
+HELP: $side-effects
+{ $values { "element" "a markup element of the form " { $snippet "{ string... }" } } }
+{ $description "Prints a heading followed by a list of input values or variables which are modified by the word being documented." }
+{ $examples
+ { $markup-example
+ { { $values { "seq" "a mutable sequence" } } { $side-effects "seq" } }
+ }
+} ;
+
+HELP: $notes
+{ $values { "element" "a markup element" } }
+{ $description "Prints the notes subheading found on the help page of some words. This section should document usage tips and pitfalls." } ;
+
+HELP: $see
+{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }
+{ $description "Prints the definition of " { $snippet "word" } " by calling " { $link see } "." }
+{ $examples
+ { $markup-example { "Here is a word definition:" { $see reverse } } }
+} ;
+
+HELP: $definition
+{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }
+{ $description "Prints a heading followed by the definition of " { $snippet "word" } " by calling " { $link see } "." } ;
+
+HELP: $curious
+{ $values { "element" "a markup element" } }
+{ $description "Prints a heading followed by a markup element." }
+{ $notes "This element type is used by the cookbook-style introductory articles in the " { $link "handbook" } "." } ;
+
+HELP: $references
+{ $values { "element" "a markup element of the form " { $snippet "{ topic... }" } } }
+{ $description "Prints a heading followed by a series of links." }
+{ $notes "This element type is used by the cookbook-style introductory articles in the " { $link "handbook" } "." } ;
+
+HELP: HELP:
+{ $syntax "HELP: word content... ;" }
+{ $values { "word" "a word" } { "content" "markup elements" } }
+{ $description "Defines documentation for a word." }
+{ $examples
+ { $code
+ "USING: help help.markup help.syntax math ;"
+ ": foo ( m -- n ) 2 + ;"
+ "HELP: foo"
+ "{ $values { \"m\" integer } { \"n\" integer } }"
+ "{ $description \"Increments a value by 2.\" } ;"
+ "\\ foo help"
+ }
+} ;
+
+HELP: ARTICLE:
+{ $syntax "ARTICLE: topic title content... ;" }
+{ $values { "topic" object } { "title" string } { "content" "markup elements" } }
+{ $description "Defines a help article. String topic names are reserved for core documentation. Contributed modules should name articles by arrays, where the first element of an array identifies the module; for example, " { $snippet "{ \"httpd\" \"intro\" }" } "." }
+{ $examples
+ { $code
+ "USING: help help.syntax ;"
+ "ARTICLE: \"example\" \"An example article\""
+ "\"Hello world.\" ;"
+ "\"example\" help"
+ }
+} ;
+
+HELP: ABOUT:
+{ $syntax "ABOUT: article" }
+{ $values { "article" "a help article" } }
+{ $description "Defines the main documentation article for the current vocabulary." } ;
+
+HELP: vocab-help
+{ $values { "vocab-spec" "a vocabulary specifier" } { "help" "a help article" } }
+{ $description "Outputs the main help article for a vocabulary. The main help article can be set with " { $link POSTPONE: ABOUT: } "." } ;
+
+HELP: orphan-articles
+{ $values { "seq" "vocab names" } }
+{ $description "Retrieves all vocabs without parents, except for 'help.home' and 'handbook' which are special." } ;
--- /dev/null
+! Copyright (C) 2005, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes classes.error combinators
+combinators.short-circuit continuations debugger effects fry
+generic help.crossref help.markup help.stylesheet help.topics io
+io.styles kernel make namespaces prettyprint sequences sets
+sorting vocabs words words.alias words.symbol ;
+IN: help
+
+GENERIC: word-help* ( word -- content )
+
+<PRIVATE
+
+: inputs-and-outputs ( content word -- content' word )
+ over [ dup array? [ { $values } head? ] [ drop f ] if ] find drop [
+ '[ _ cut unclip rest ] dip [
+ stack-effect [ in>> ] [ out>> ] bi
+ [ [ dup pair? [ first ] when ] map ] bi@
+ [ '[ ?first _ member? ] filter ] bi-curry@
+ \ $inputs \ $outputs
+ [ '[ @ _ prefix ] ] bi-curry@ bi* bi
+ 2array glue
+ ] keep
+ ] when* ;
+
+: fix-shuffle ( content word -- content' word )
+ over [ { $shuffle $complex-shuffle } member? ] find drop [
+ '[ _ cut unclip ] dip [
+ stack-effect 2array 1array glue
+ ] keep
+ ] when* ;
+
+PRIVATE>
+
+: word-help ( word -- content )
+ [ dup "help" word-prop [ ] [ word-help* ] ?if ] keep
+ inputs-and-outputs fix-shuffle drop ;
+
+: effect-help ( effect -- content )
+ [ in>> ] [ out>> ] bi [
+ [
+ dup pair? [
+ first2 dup effect? [ \ $quotation swap 2array ] when
+ ] [
+ object
+ ] if [ effect>string ] dip
+ ] { } map>assoc
+ ] bi@ \ $inputs \ $outputs [ prefix ] bi-curry@ bi* 2array ;
+
+! M: word word-help* stack-effect effect-help ;
+
+! skov
+M: word word-help*
+ stack-effect [ in>> ] [ out>> ] bi [
+ [
+ dup pair? [
+ first2 dup effect? [ \ $quotation swap 2array ] when
+ ] [
+ object
+ ] if [ effect>string ] dip
+ ] { } map>assoc
+ ] bi@ [ \ $inputs prefix ] dip \ $outputs prefix 2array ;
+
+: $predicate ( element -- )
+ { { "object" object } { "?" boolean } } $values
+ [
+ "Tests if the object is an instance of the " ,
+ first "predicating" word-prop <$link> ,
+ " class." ,
+ ] { } make $description ;
+
+M: predicate word-help* \ $predicate swap 2array 1array ;
+
+M: class word-help* drop f ;
+
+M: alias word-help*
+ [
+ \ $description ,
+ "An alias for " , def>> first <$link> , "." ,
+ ] { } make 1array ;
+
+: all-articles ( -- seq )
+ articles get keys
+ all-words [ word-help ] filter append ;
+
+: orphan-articles ( -- seq )
+ articles get keys [ article-parent ] reject
+ { "help.home" "handbook" } diff ;
+
+: xref-help ( -- )
+ all-articles [ xref-article ] each ;
+
+: error? ( word -- ? )
+ {
+ [ error-class? ]
+ [ \ $error-description swap word-help elements empty? not ]
+ } 1|| ;
+
+: sort-articles ( seq -- newseq )
+ [ article-title ] zip-with sort-values keys ;
+
+: all-errors ( -- seq )
+ all-words [ error? ] filter sort-articles ;
+
+M: word valid-article? drop t ;
+
+M: word article-name name>> ;
+
+! M: word article-title
+! dup [ parsing-word? ] [ symbol? ] bi or [
+! name>>
+! ] [
+! [ unparse ]
+! [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
+! append
+! ] if ;
+
+! skov
+M: word article-title
+ dup [ parsing-word? ] [ symbol? ] bi or [ name>> ] [ unparse ] if ;
+
+<PRIVATE
+
+! : (word-help) ( word -- element )
+! [
+! {
+! [ \ $vocabulary swap 2array , ]
+! [ word-help % ]
+! [ \ $related swap 2array , ]
+! [ dup global at [ get-global \ $value swap 2array , ] [ drop ] if ]
+! [ \ $definition swap 2array , ]
+! } cleave
+! ] { } make ;
+
+! skov
+: (word-help) ( word -- element )
+ [
+ {
+ [ \ $vocabulary swap 2array , ]
+ [ \ $graph swap 2array , ]
+ [ word-help % ]
+ [ dup global at [ get-global \ $value swap 2array , ] [ drop ] if ]
+ [ \ $definition swap 2array , ]
+ [ \ $related swap 2array , ]
+ } cleave
+ ] { } make ;
+
+M: word article-content (word-help) ;
+
+: word-with-methods ( word -- elements )
+ [
+ [ (word-help) % ]
+ [ \ $methods swap 2array , ]
+ bi
+ ] { } make ;
+
+PRIVATE>
+
+M: generic article-content word-with-methods ;
+
+! M: class article-content word-with-methods ;
+
+! skov
+M: class article-content (word-help) ;
+
+M: word article-parent "help-parent" word-prop ;
+
+M: word set-article-parent swap "help-parent" set-word-prop ;
+
+: ($title) ( topic -- )
+ [ [ article-title ] [ >link ] bi write-object ] ($block) ;
+
+: ($navigation-table) ( element -- )
+ help-path-style get dup [
+ table-style [ $table ] with-variable
+ ] with-style ;
+
+: ($navigation-path) ( topic -- )
+ help-path-style get [
+ help-path [ reverse $breadcrumbs ] unless-empty
+ ] with-style ;
+
+: ($navigation-link) ( content element label -- )
+ [ prefix 1array ] dip prefix , ;
+
+: ($navigation-links) ( topic -- )
+ [
+ [ prev-article [ 1array \ $long-link "Prev:" ($navigation-link) ] when* ]
+ [ next-article [ 1array \ $long-link "Next:" ($navigation-link) ] when* ]
+ bi
+ ] { } make [ ($navigation-table) ] unless-empty ;
+
+: $title ( topic -- )
+ title-style get [
+ [ ($title) ]
+ [ ($navigation-path) ]
+ [ ($navigation-links) ] tri
+ ] with-nesting ;
+
+: print-topic ( topic -- )
+ >link
+ last-element off
+ [ $title ($blank-line) ]
+ [ article-content print-content nl ] bi ;
+
+SYMBOL: help-hook
+
+help-hook [ [ print-topic ] ] initialize
+
+: help ( topic -- )
+ help-hook get call( topic -- ) ;
+
+: ($index) ( articles -- )
+ sort-articles [ \ $subsection swap 2array ] map print-element ;
+
+: $index ( element -- )
+ first call( -- seq ) [ ($index) ] unless-empty ;
+
+: $about ( element -- )
+ first vocab-help [ 1array $subsection ] when* ;
+
+: :help-debugger ( -- )
+ nl
+ "Debugger commands:" print
+ nl
+ ":s - data stack at error time" print
+ ":r - retain stack at error time" print
+ ":c - call stack at error time" print
+ ":edit - jump to source location (parse errors only)" print
+
+ ":get ( var -- value ) accesses variables at time of the error" print
+ ":vars - list all variables at error time" print ;
+
+: (:help) ( error -- )
+ error-help [ help ] [ "No help for this error. " print ] if*
+ :help-debugger ;
+
+: :help ( -- )
+ error get (:help) ;
+
+: remove-article ( name -- )
+ articles get delete-at ;
+
+: add-article ( article name -- )
+ [ articles get set-at ] keep xref-article ;
+
+: remove-word-help ( word -- )
+ "help" remove-word-prop ;
+
+: set-word-help ( content word -- )
+ [ swap "help" set-word-prop ] keep xref-article ;
--- /dev/null
+! Copyright (C) 2005, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators compiler.units
+definitions.icons effects hashtables help.stylesheet help.topics
+io io.styles kernel make math namespaces present prettyprint
+prettyprint.stylesheet quotations see sequences
+sequences.private sets sorting splitting strings urls vocabs
+words words.symbol ;
+FROM: prettyprint.sections => with-pprint ;
+IN: help.markup
+
+PREDICATE: simple-element < array
+ [ t ] [ first word? not ] if-empty ;
+
+SYMBOL: last-element
+SYMBOL: span
+SYMBOL: block
+SYMBOL: blank-line
+
+: last-span? ( -- ? ) last-element get span eq? ;
+: last-block? ( -- ? ) last-element get block eq? ;
+: last-blank-line? ( -- ? ) last-element get blank-line eq? ;
+
+: ?nl ( -- )
+ last-element get
+ last-blank-line? not
+ and [ nl ] when ;
+
+: ($blank-line) ( -- )
+ nl nl blank-line last-element namespaces:set ;
+
+: ($span) ( quot -- )
+ last-block? [ nl ] when
+ span last-element namespaces:set
+ call ; inline
+
+GENERIC: print-element ( element -- )
+
+M: simple-element print-element [ print-element ] each ;
+M: string print-element [ write ] ($span) ;
+M: array print-element unclip execute( arg -- ) ;
+M: word print-element { } swap execute( arg -- ) ;
+M: effect print-element effect>string print-element ;
+M: f print-element drop ;
+
+: print-element* ( element style -- )
+ [ print-element ] with-style ;
+
+: with-default-style ( quot -- )
+ default-style get swap with-nesting ; inline
+
+: print-content ( element -- )
+ [ print-element ] with-default-style ;
+
+: ($block) ( quot -- )
+ ?nl
+ span last-element namespaces:set
+ call
+ block last-element namespaces:set ; inline
+
+! Some spans
+
+: $snippet ( children -- )
+ [ snippet-style get print-element* ] ($span) ;
+
+: $emphasis ( children -- )
+ [ emphasis-style get print-element* ] ($span) ;
+
+: $strong ( children -- )
+ [ strong-style get print-element* ] ($span) ;
+
+: $url ( children -- )
+ [ ?second ] [ first ] bi [ or ] keep >url [
+ dup present href associate url-style get assoc-union
+ [ write-object ] with-style
+ ] ($span) ;
+
+: $nl ( children -- )
+ drop nl last-element get [ nl ] when
+ blank-line last-element namespaces:set ;
+
+! Some blocks
+: ($heading) ( children quot -- )
+ ?nl ($block) ; inline
+
+: $heading ( element -- )
+ [ heading-style get print-element* ] ($heading) ;
+
+: $subheading ( element -- )
+ [ strong-style get print-element* ] ($heading) ;
+
+: ($code-style) ( presentation -- hash )
+ presented associate code-style get assoc-union ;
+
+: ($code) ( presentation quot -- )
+ [
+ last-element off
+ [ ($code-style) ] dip with-nesting
+ ] ($block) ; inline
+
+: $code ( element -- )
+ join-lines dup <input> [ write ] ($code) ;
+
+: $syntax ( element -- ) "Syntax" $heading $code ;
+
+: $description ( element -- )
+ "Word description" $heading print-element ;
+
+: $class-description ( element -- )
+ "Class description" $heading print-element ;
+
+: $error-description ( element -- )
+ "Error description" $heading print-element ;
+
+: $var-description ( element -- )
+ "Variable description" $heading print-element ;
+
+: $contract ( element -- )
+ "Generic word contract" $heading print-element ;
+
+: $examples ( element -- )
+ "Examples" $heading print-element ;
+
+: $example ( element -- )
+ unclip-last [ join-lines ] dip over <input> [
+ [ print ] [ output-style get format ] bi*
+ ] ($code) ;
+
+: $unchecked-example ( element -- )
+ ! help-lint ignores these.
+ $example ;
+
+: $markup-example ( element -- )
+ first dup unparse " print-element" append 1array $code
+ print-element ;
+
+: $warning ( element -- )
+ [
+ warning-style get [
+ last-element off
+ "Warning" $heading print-element
+ ] with-nesting
+ ] ($heading) ;
+
+: $deprecated ( element -- )
+ [
+ deprecated-style get [
+ last-element off
+ "This word is deprecated" $heading print-element
+ ] with-nesting
+ ] ($heading) ;
+
+! Images
+: $image ( element -- )
+ [ first write-image ] ($span) ;
+
+: <$image> ( path -- element )
+ 1array \ $image prefix ;
+
+! Some links
+
+<PRIVATE
+
+: write-link ( string object -- )
+ link-style get [ write-object ] with-style ;
+
+: link-icon ( topic -- )
+ definition-icon 1array $image ;
+
+: link-text ( topic -- )
+ [ article-name ] keep write-link ;
+
+GENERIC: link-long-text ( topic -- )
+
+M: topic link-long-text
+ [ article-title ] keep write-link ;
+
+GENERIC: link-effect? ( word -- ? )
+
+M: parsing-word link-effect? drop f ;
+M: symbol link-effect? drop f ;
+M: word link-effect? drop t ;
+
+: $effect ( effect -- )
+ effect>string base-effect-style get format ;
+
+M: word link-long-text
+ dup presented associate [
+ [ article-name link-style get format ]
+ [
+ dup link-effect? [
+ bl stack-effect $effect
+ ] [ drop ] if
+ ] bi
+ ] with-nesting ;
+
+: >topic ( obj -- topic ) dup topic? [ >link ] unless ;
+
+: topic-span ( topic quot -- ) [ >topic ] dip ($span) ; inline
+
+ERROR: number-of-arguments found required ;
+
+: check-first ( seq -- first )
+ dup length 1 = [ length 1 number-of-arguments ] unless
+ first-unsafe ;
+
+: check-first2 ( seq -- first second )
+ dup length 2 = [ length 2 number-of-arguments ] unless
+ first2-unsafe ;
+
+PRIVATE>
+
+: ($link) ( topic -- ) [ link-text ] topic-span ;
+
+: $link ( element -- ) check-first ($link) ;
+
+: ($long-link) ( topic -- ) [ link-long-text ] topic-span ;
+
+: $long-link ( element -- ) check-first ($long-link) ;
+
+: ($pretty-link) ( topic -- )
+ [ [ link-icon ] [ drop bl ] [ link-text ] tri ] topic-span ;
+
+: $pretty-link ( element -- ) check-first ($pretty-link) ;
+
+: ($long-pretty-link) ( topic -- )
+ [ [ link-icon ] [ drop bl ] [ link-long-text ] tri ] topic-span ;
+
+: <$pretty-link> ( definition -- element )
+ 1array \ $pretty-link prefix ;
+
+: ($subsection) ( element quot -- )
+ [
+ subsection-style get [ call ] with-style
+ ] ($block) ; inline
+
+: $subsection* ( topic -- )
+ [
+ [ ($long-pretty-link) ] with-scope
+ ] ($subsection) ;
+
+: $subsections ( children -- )
+ [ $subsection* ] each ($blank-line) ;
+
+: $subsection ( element -- )
+ check-first $subsection* ;
+
+: ($vocab-link) ( text vocab -- )
+ >vocab-link write-link ;
+
+: $vocab-subsection ( element -- )
+ [
+ check-first2 dup vocab-help
+ [ 2nip ($long-pretty-link) ]
+ [ [ >vocab-link link-icon bl ] [ ($vocab-link) ] bi ]
+ if*
+ ] ($subsection) ;
+
+: $vocab-subsections ( element -- )
+ [ $vocab-subsection ] each ($blank-line) ;
+
+: $vocab-link ( element -- )
+ check-first [ vocab-name ] keep ($vocab-link) ;
+
+: $vocabulary ( element -- )
+ check-first vocabulary>> [
+ "Vocabulary" $heading nl dup ($vocab-link)
+ ] when* ;
+
+: (textual-list) ( seq quot sep -- )
+ '[ _ print-element ] swap interleave ; inline
+
+: textual-list ( seq quot -- )
+ ", " (textual-list) ; inline
+
+: $links ( topics -- )
+ [ [ ($link) ] textual-list ] ($span) ;
+
+: $vocab-links ( vocabs -- )
+ [ lookup-vocab ] map $links ;
+
+: $breadcrumbs ( topics -- )
+ [ [ ($link) ] " » " (textual-list) ] ($span) ;
+
+: $see-also ( topics -- )
+ "See also" $heading $links ;
+
+<PRIVATE
+:: update-related-words ( words -- affected-words )
+ words words [| affected word |
+ word "related" [ affected union words ] change-word-prop
+ ] reduce ;
+
+:: clear-unrelated-words ( words affected-words -- )
+ affected-words words diff
+ [ "related" [ words diff ] change-word-prop ] each ;
+
+: notify-related-words ( affected-words -- )
+ fast-set notify-definition-observers ;
+
+PRIVATE>
+
+: related-words ( seq -- )
+ dup update-related-words
+ [ clear-unrelated-words ] [ notify-related-words ] bi ;
+
+: $related ( element -- )
+ check-first dup "related" word-prop remove
+ [ $see-also ] unless-empty ;
+
+: ($grid) ( style content-style quot -- )
+ '[
+ _ [ last-element off _ tabular-output ] with-style
+ ] ($block) ; inline
+
+: $list ( element -- )
+ list-style get list-content-style get [
+ [
+ [
+ bullet get write-cell
+ [ print-element ] with-cell
+ ] with-row
+ ] each
+ ] ($grid) ;
+
+: $table ( element -- )
+ table-style get table-content-style get [
+ [
+ [
+ [ [ print-element ] with-cell ] each
+ ] with-row
+ ] each
+ ] ($grid) ;
+
+! for help-lint
+ALIAS: $slot $snippet
+
+: $slots ( children -- )
+ [ unclip \ $slot swap 2array prefix ] map $table ;
+
+: a/an ( str -- str )
+ [ first ] [ length ] bi 1 =
+ "afhilmnorsx" "aeiou" ? member? "an" "a" ? ;
+
+GENERIC: ($instance) ( element -- )
+
+M: word ($instance) dup name>> a/an write bl ($link) ;
+
+M: string ($instance) write ;
+
+M: array ($instance) print-element ;
+
+M: f ($instance) ($link) ;
+
+: $instance ( element -- ) first ($instance) ;
+
+: $or ( element -- )
+ dup length {
+ { 1 [ first ($instance) ] }
+ { 2 [ first2 [ ($instance) " or " print-element ] [ ($instance) ] bi* ] }
+ [
+ drop
+ unclip-last
+ [ [ ($instance) ", " print-element ] each ]
+ [ "or " print-element ($instance) ]
+ bi*
+ ]
+ } case ;
+
+: $maybe ( element -- )
+ f suffix $or ;
+
+: $quotation ( element -- )
+ check-first
+ { "a " { $link quotation } " with stack effect " }
+ print-element $snippet ;
+
+: ($instances) ( element -- )
+ dup word? [ ($link) "s" print-element ] [ print-element ] if ;
+
+: $sequence ( element -- )
+ { "a " { $link sequence } " of " } print-element
+ dup length {
+ { 1 [ first ($instances) ] }
+ { 2 [ first2 [ ($instances) " or " print-element ] [ ($instances) ] bi* ] }
+ [
+ drop
+ unclip-last
+ [ [ ($instances) ", " print-element ] each ]
+ [ "or " print-element ($instances) ]
+ bi*
+ ]
+ } case ;
+
+: values-row ( seq -- seq )
+ unclip \ $snippet swap present 2array
+ swap dup first word? [ \ $instance prefix ] when 2array ;
+
+: ($values) ( element -- )
+ [ [ "None" write ] ($block) ]
+ [ [ values-row ] map $table ] if-empty ;
+
+! : $inputs ( element -- )
+! "Inputs" $heading ($values) ;
+
+! skov
+: $inputs ( element -- )
+ "Inputs" $heading
+ [ [ "none" print ] ($block) ]
+ [ [ values-row ] map $table ] if-empty ;
+
+! : $outputs ( element -- )
+! "Outputs" $heading ($values) ;
+
+! skov
+: $outputs ( element -- )
+ "Outputs" $heading
+ [ [ "none" print ] ($block) ]
+ [ [ values-row ] map $table ] if-empty ;
+
+: $values ( element -- )
+ "Inputs and outputs" $heading ($values) ;
+
+: $side-effects ( element -- )
+ "Side effects" $heading "Modifies " print-element
+ [ $snippet ] textual-list ;
+
+: $errors ( element -- )
+ "Errors" $heading print-element ;
+
+: $notes ( element -- )
+ "Notes" $heading print-element ;
+
+: ($see) ( word quot -- )
+ [ code-style get swap with-nesting ] ($block) ; inline
+
+: $see ( element -- ) check-first [ see* ] ($see) ;
+
+! skov
+! : $see ( element -- )
+! check-first <definition-tree> nl output-stream get write-gadget ;
+
+: $synopsis ( element -- ) check-first [ synopsis write ] ($see) ;
+
+: $definition ( element -- )
+ "Definition" $heading $see ;
+
+: $methods ( element -- )
+ check-first methods [
+ "Methods" $heading
+ [ see-all ] ($see)
+ ] unless-empty ;
+
+: $value ( object -- )
+ "Variable value" $heading
+ "Current value in global namespace:" print-element
+ check-first dup [ pprint-short ] ($code) ;
+
+: $curious ( element -- )
+ "For the curious..." $heading print-element ;
+
+: $references ( element -- )
+ "References" $heading
+ unclip print-element [ \ $link swap ] { } map>assoc $list ;
+
+: $shuffle ( element -- )
+ "This is a shuffle word, rearranging the top of the datastack as indicated by the word's stack effect" swap
+ ?first [ ": " swap "." 4array ] [ "." append ] if*
+ $description ;
+
+: $complex-shuffle ( element -- )
+ $shuffle
+ { "The data flow represented by this shuffle word might be more clearly expressed using " { $link "locals" } "." } $deprecated ;
+
+: $low-level-note ( children -- )
+ drop
+ "Calling this word directly is not necessary in most cases. Higher-level words call it automatically." $notes ;
+
+: $values-x/y ( children -- )
+ drop { { "x" number } { "y" number } } $values ;
+
+: $parsing-note ( children -- )
+ drop
+ "This word should only be called from parsing words."
+ $notes ;
+
+: $io-error ( children -- )
+ drop
+ "Throws an error if the I/O operation fails." $errors ;
+
+: $prettyprinting-note ( children -- )
+ drop {
+ "This word should only be called from inside the "
+ { $link with-pprint } " combinator."
+ } $notes ;
+
+: $content ( element -- )
+ first article-content print-content nl ;
+
+GENERIC: elements* ( elt-type element -- )
+
+M: simple-element elements*
+ [ elements* ] with each ;
+
+M: object elements* 2drop ;
+
+M: array elements*
+ [ dup first \ $markup-example eq? [ 2drop ] [ [ elements* ] with each ] if ]
+ [ [ first eq? ] keep swap [ , ] [ drop ] if ] 2bi ;
+
+: elements ( elt-type element -- seq ) [ elements* ] { } make ;
+
+: collect-elements ( element seq -- elements )
+ swap '[ [ _ elements* ] each ] { } make [ rest ] map concat ;
+
+: <$link> ( topic -- element )
+ 1array \ $link prefix ;
+
+: <$snippet> ( str -- element )
+ 1array \ $snippet prefix ;
+
+: $definition-icons ( element -- )
+ drop
+ icons get sort-keys
+ [ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map
+ { f { $strong "Definition class" } } prefix
+ $table ;
+
+! skov
+DEFER: <help-tree>
+DEFER: write-gadget
+: $graph ( element -- )
+ check-first <help-tree> nl nl output-stream get write-gadget ;
+
--- /dev/null
+! 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
+: euler ( -- gamma ) 0.57721566490153286060 ; inline
+: phi ( -- phi ) 1.61803398874989484820 ; inline
+: pi ( -- pi ) 3.14159265358979323846 ; inline
+: 2pi ( -- pi ) 2 pi * ; inline
+: epsilon ( -- epsilon ) 0x3cb0000000000000 bits>double ; foldable
+: single-epsilon ( -- epsilon ) 0x34000000 bits>float ; foldable
+: smallest-float ( -- x ) 0x1 bits>double ; foldable
+: largest-float ( -- x ) 0x7fefffffffffffff bits>double ; foldable
+: tau ( -- tau ) 2 pi * ; inline
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs help.markup kernel make quotations
+sequences splitting tr ui.gestures unicode words ;
+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 ;
+
+TR: convert-command-name "-" " " ;
+
+: (command-name) ( string -- newstring )
+ convert-command-name >title ;
+
+: get-command-at ( group class -- command-map )
+ commands at ;
+
+: command-map-row ( gesture command -- seq )
+ [
+ [ gesture>string , ]
+ [
+ [ command-name , ]
+ [ command-word <$link> , ]
+ [ 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 get-command-at
+ [ blurb>> print-element ] [ commands>> command-map. ] bi
+ ] bi ;
+
+: $command ( element -- )
+ reverse first3 get-command-at
+ commands>> value-at gesture>string
+ $snippet ;
+
+: command-gestures ( class -- hash )
+ commands values [
+ [
+ commands>>
+ sift-keys
+ [ '[ _ invoke-command ] swap ,, ] assoc-each
+ ] each
+ ] H{ } make ;
+
+: update-gestures ( class -- )
+ dup command-gestures set-gestures ;
+
+: define-command-map ( class group blurb pairs -- )
+ <command-map>
+ swap pick commands set-at
+ update-gestures ;
+
+M: word command-name
+ name>>
+ "com-" ?head drop "." ?tail drop
+ dup first Letter? [ rest ] unless
+ (command-name) ;
+
+! skov
+! M: word command-name
+! name>> "com " ?head drop "." ?tail drop
+! dup first Letter? [ rest ] unless
+! (command-name) ;
+
+M: word command-description
+ +description+ word-prop ;
+
+: default-flags ( -- assoc )
+ H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
+
+: define-command ( word hash -- )
+ default-flags swap assoc-union
+ '[ _ assoc-union ] change-props drop ;
+
+: command-quot ( target command -- quot )
+ [ 1quotation ] [ +nullary+ word-prop ] bi
+ [ nip ] [ curry ] if ;
+
+M: word invoke-command
+ command-quot call( -- ) ;
+
+M: word command-word ;
+
+M: f invoke-command 2drop ;
--- /dev/null
+! Copyright (C) 2016 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors code.execution combinators.smart help.topics
+kernel locals models ui.gadgets ui.gadgets.buttons.round
+ui.gadgets.packs ui.tools.environment.theme vocabs words ;
+IN: ui.gadgets.buttons.activate
+
+: vocab/word? ( obj -- ? )
+ [ vocab? ] [ [ link? ] [ name>> word? ] [ drop f ] smart-if ] bi or ;
+
+: vocab-name ( obj -- str )
+ name>> [ word? ] [ vocabulary>> ] smart-when ;
+
+:: <activate-button> ( model -- gadget )
+ model value>> vocab-name :> name
+ name interactive?
+ [ blue-background "Active"
+ [ drop name remove-interactive-vocab model notify-connections ]
+ <round-button> "Deactivate this vocabulary" >>tooltip ]
+ [ dark-background "Inactive"
+ [ drop name add-interactive-vocab model notify-connections ]
+ <round-button> "Activate this vocabulary" >>tooltip ] if ;
+
+TUPLE: active/inactive < pack ;
+
+: <active/inactive> ( model -- gadget )
+ active/inactive new swap >>model ;
+
+M: active/inactive model-changed
+ dup clear-gadget swap
+ [ value>> vocab/word? ] [ <activate-button> add-gadget ] smart-when* drop ;
--- /dev/null
+! Copyright (C) 2015 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays colors colors.gray kernel locals math
+math.order sequences ui.gadgets ui.gadgets.buttons combinators.smart
+ui.pens.gradient-rounded ui.tools.environment.theme ;
+IN: ui.gadgets.buttons.round
+
+TUPLE: round-button < button ;
+
+M: round-button pref-dim*
+ gadget-child [ text>> length 1 > ]
+ [ pref-dim first2 [ 15 + ] dip [ 20 max ] bi@ 2array ]
+ [ { 20 20 } ] smart-if* ;
+
+:: <round-button> ( colors label quot -- button )
+ label quot round-button new-button
+ colors dup first >gray gray>> 0.5 < light-text-colour dark-text-colour ?
+ <gradient-squircle> >>interior
+ dup gadget-child
+ [ t >>bold? 13 >>size transparent >>background ] change-font drop ;
--- /dev/null
+USING: accessors arrays assocs colors combinators
+combinators.short-circuit combinators.smart kernel locals math
+math.functions math.order math.ranges math.vectors opengl.gl
+sequences ui.gadgets ui.gadgets.packs ui.pens ui.pens.caching
+ui.pens.gradient system ;
+IN: ui.pens.gradient-rounded
+
+TUPLE: gradient-shape < caching-pen colors foreground shape last-vertices last-colors ;
+TUPLE: gradient-squircle < gradient-shape ;
+TUPLE: gradient-arrow < gradient-shape ;
+TUPLE: gradient-pointy < gradient-shape ;
+TUPLE: gradient-dynamic-shape < gradient-shape selected? ;
+
+: <gradient-squircle> ( colors foreground -- gradient )
+ gradient-squircle new swap >>foreground swap >>colors ;
+
+: <gradient-arrow> ( colors foreground -- gradient )
+ gradient-arrow new swap >>foreground swap >>colors ;
+
+: <gradient-pointy> ( colors foreground -- gradient )
+ gradient-pointy new swap >>foreground swap >>colors ;
+
+: <gradient-dynamic-shape> ( colors foreground selected? -- gradient )
+ gradient-dynamic-shape new swap >>selected? swap >>foreground swap >>colors ;
+
+<PRIVATE
+
+CONSTANT: tau 6.283185307179586
+CONSTANT: points 100
+
+: squircle-point ( theta -- xy )
+ [ cos ] [ sin ] bi [ [ abs sqrt ] [ sgn ] bi * 0.5 * 0.5 + ] bi@ 2array ;
+
+:: tan-point ( y slope -- xy )
+ y tau * 4 / tan 300 / 0.5 min y slope / + y 2array ;
+
+:: squircle ( -- seq )
+ 1/4 tau * 3/4 tau * 1/2 tau * points / <range> [ squircle-point ] map ;
+
+:: arrow ( -- seq )
+ { { -0.25 1 } { 0 0.5 } { -0.25 0 } } ;
+
+:: wide-narrow ( slope -- seq )
+ 0.0 1.0 1 points / <range> [ slope tan-point ] map reverse ;
+
+: narrow-wide ( slope -- seq )
+ wide-narrow unzip [ reverse ] dip zip ;
+
+:: wide-narrow-wide ( slope -- seq )
+ slope wide-narrow unzip drop slope narrow-wide unzip [ [ min ] 2map ] dip zip ;
+
+:: narrow-wide-narrow ( slope -- seq )
+ slope wide-narrow unzip drop slope narrow-wide unzip [ [ max ] 2map ] dip zip ;
+
+:: vertices ( dim left-shape right-shape symmetric? -- seq )
+ dim first2 :> ( x y )
+ left-shape right-shape [ call( -- seq ) [ y v*n ] map ] bi@
+ reverse symmetric? [ [ first2 [ neg ] dip 2array ] map ] unless
+ [ first2 swap x swap - swap 2array ] map append
+ x 2 / y 2 / 2array prefix dup second suffix ;
+
+:: interp-color ( x colors -- seq )
+ colors [ >rgba-components 4array ] map first2 zip [ first2 dupd - x * - ] map ;
+
+:: vertices-colors ( dim seq colors -- seq )
+ seq [ second dim second / colors interp-color ] map ;
+
+: draw-triangle-fan ( vertices colors -- )
+ GL_TRIANGLE_FAN glBegin
+ [ first3 glColor3f first2 glVertex2f ] 2each
+ glEnd ;
+
+:: gradient-start ( edge center -- s )
+ center first2 :> ( xc yc )
+ edge first2 :> ( xe ye )
+ 8 xe xc - sq ye yc - sq + sqrt / :> alpha
+ xe xe xc - alpha * -
+ ye ye yc - alpha * - 8 max 16 min 2array ;
+
+: draw-triangle-fan-selected ( vertices -- )
+ unclip dupd [ gradient-start ] curry map
+ GL_TRIANGLE_STRIP glBegin
+ [ 1.0 1.0 1.0 0.0 glColor4f first2 glVertex2f
+ 1.0 1.0 1.0 0.6 glColor4f first2 glVertex2f ] 2each
+ glEnd ;
+
+: left ( gadget -- dim ) screen-loc first ;
+: right ( gadget -- dim ) [ screen-loc first ] [ dim>> first ] bi + ;
+
+: default-value ( side -- x )
+ \ left = 10000 0 ? ;
+
+: compare ( x y side -- ? )
+ \ left = [ 3 - < ] [ 3 + > ] if ;
+
+:: above ( gadget side -- dim )
+ gadget parent>> gadget-child children>> [ empty? not ]
+ [ side \ left = [ first ] [ last ] if children>> second side execute( x -- x ) ]
+ [ side default-value ] smart-if* ;
+
+:: below ( gadget side -- dim )
+ gadget parent>> parent>>
+ [ dup parent>> children>> { [ length 1 > nip ] [ second = not ] } 2&& ]
+ [ parent>> children>> second side execute( x -- x ) ]
+ [ side default-value ] smart-if* ;
+
+:: above-wider? ( gadget side -- ? )
+ gadget [ side above ] [ side execute( x -- x ) ] bi side compare ;
+
+:: below-wider? ( gadget side -- ? )
+ gadget [ side below ] [ side execute( x -- x ) ] bi side compare ;
+
+:: find-half-shape ( gadget side -- shape ) {
+ { [ gadget left 10 < ] [ [ squircle ] ] }
+ { [ gadget side above-wider? gadget side below-wider? and ] [ [ 6 wide-narrow-wide ] ] }
+ { [ gadget side above-wider? gadget side below-wider? not and ] [ [ 6 wide-narrow ] ] }
+ { [ gadget side above-wider? not gadget side below-wider? and ] [ [ 6 narrow-wide ] ] }
+ { [ gadget side above-wider? not gadget side below-wider? not and ] [ [ 6 narrow-wide-narrow ] ] }
+ } cond ;
+
+: find-shape ( gadget -- left-shape right-shape )
+ [ \ left find-half-shape ] [ \ right find-half-shape ] bi ;
+
+:: (recompute-pen) ( gadget gradient left-shape right-shape symmetric? -- )
+ gadget dim>> dup left-shape right-shape symmetric? vertices dup gradient last-vertices<<
+ gradient colors>> vertices-colors gradient last-colors<< ;
+
+M: gradient-squircle recompute-pen ( gadget gradient -- )
+ [ squircle ] dup t (recompute-pen) ;
+
+M: gradient-arrow recompute-pen ( gadget gradient -- )
+ [ arrow ] dup f (recompute-pen) ;
+
+M: gradient-pointy recompute-pen ( gadget gradient -- )
+ [ 1.5 narrow-wide-narrow ] dup t (recompute-pen) ;
+
+M:: gradient-dynamic-shape recompute-pen ( gadget gradient -- )
+ gadget gradient gadget find-shape t (recompute-pen) ;
+
+PRIVATE>
+
+M: gradient-shape draw-interior
+ [ compute-pen ]
+ [ last-vertices>> ]
+ [ last-colors>> draw-triangle-fan ] tri ;
+
+M: gradient-shape pen-background
+ 2drop transparent ;
+
+M: gradient-shape pen-foreground
+ nip foreground>> ;
+
+M: gradient-dynamic-shape draw-interior
+ [ call-next-method ]
+ [ selected?>> ]
+ [ last-vertices>> ] tri
+ [ draw-triangle-fan-selected ] curry when ;
--- /dev/null
+USING: accessors colors kernel locals math opengl opengl.gl
+sequences ui.pens ui.tools.environment.theme system ;
+IN: ui.pens.title-gradient
+
+TUPLE: title-gradient colors foreground selected? ;
+
+: <title-gradient> ( colors foreground selected? -- gradient )
+ title-gradient new swap >>selected? swap >>foreground swap >>colors ;
+
+:: draw-gradient ( dim gradient -- )
+ GL_QUADS glBegin
+ gradient first >rgba-components glColor4f
+ 0.0 0.0 glVertex2f
+ dim first 0.0 glVertex2f
+ gradient second >rgba-components glColor4f
+ dim first2 glVertex2f
+ 0.0 dim second glVertex2f
+ glEnd ;
+
+:: draw-underline ( dim gradient -- )
+ 1 gl-scale glLineWidth
+ GL_LINES glBegin
+ gradient first >rgba-components glColor4f
+ 0.0 dim second glVertex2f
+ dim first2 glVertex2f
+ glEnd ;
+
+CONSTANT: shadow-width 20.0
+
+:: draw-shadows ( dim -- )
+ GL_QUADS glBegin
+ content-background-colour >rgba-components glColor4f
+ 0.0 0.0 glVertex2f
+ 0.0 dim second 1 + glVertex2f
+ content-background-colour >rgba-components drop 0.0 glColor4f
+ shadow-width dim second 1 + glVertex2f
+ shadow-width 0.0 glVertex2f
+ content-background-colour >rgba-components glColor4f
+ dim first 0.0 glVertex2f
+ dim first dim second 1 + glVertex2f
+ content-background-colour >rgba-components drop 0.0 glColor4f
+ dim first shadow-width - dim second 1 + glVertex2f
+ dim first shadow-width - 0.0 glVertex2f
+ glEnd ;
+
+: draw-title ( dim gradient -- )
+ [ draw-gradient ] [ draw-underline ] [ drop draw-shadows ] 2tri ;
+
+M: title-gradient draw-interior
+ [ dim>> ] dip colors>> draw-title ;
+
+M: title-gradient pen-background
+ 2drop transparent ;
+
+M: title-gradient pen-foreground
+ nip foreground>> ;
--- /dev/null
+! Copyright (C) 2005, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators fry kernel math math.order
+math.vectors models models.range ui.gadgets ui.gadgets.buttons
+ui.gadgets.icons ui.gadgets.tracks ui.gestures ui.pens
+ui.pens.image ui.pens.tile ui.theme.images ;
+IN: ui.gadgets.sliders
+
+TUPLE: slider < track elevator thumb saved line ;
+
+: slider-value ( gadget -- n ) model>> range-value ;
+: slider-page ( gadget -- n ) model>> range-page-value ;
+: slider-min ( gadget -- n ) model>> range-min-value ;
+: slider-max ( gadget -- n ) model>> range-max-value ;
+: slider-max* ( gadget -- n ) model>> range-max-value* ;
+
+: slider-length ( gadget -- n ) [ slider-max ] [ slider-min ] bi - ;
+: slider-length* ( gadget -- n ) [ slider-max* ] [ slider-min ] bi - ;
+
+: slide-by ( amount slider -- ) model>> move-by ;
+: slide-by-page ( amount slider -- ) model>> move-by-page ;
+
+: slide-by-line ( amount slider -- ) [ line>> * ] keep slide-by ;
+
+<PRIVATE
+
+TUPLE: elevator < gadget direction ;
+
+: find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
+
+CONSTANT: elevator-padding 4
+
+: elevator-length ( slider -- n )
+ [ elevator>> dim>> ] [ orientation>> ] bi vdot
+ elevator-padding 2 * [-] ;
+
+CONSTANT: min-thumb-dim 30
+
+: visible-portion ( slider -- n )
+ [ slider-page ]
+ [ slider-length 1 max ]
+ bi / 1 min ;
+
+: thumb-dim ( slider -- h )
+ [
+ [ visible-portion ] [ elevator-length ] bi *
+ min-thumb-dim max
+ ]
+ [ elevator-length ] bi 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.
+ [ [ elevator-length ] [ thumb-dim ] bi - 1 max ]
+ [ slider-length* 1 max ]
+ bi / ;
+
+: slider>screen ( m slider -- n ) slider-scale * ;
+: screen>slider ( m slider -- n ) slider-scale / ;
+
+M: slider model-changed nip elevator>> relayout-1 ;
+
+TUPLE: thumb < track ;
+
+: begin-drag ( thumb -- )
+ find-slider dup slider-value >>saved drop ;
+
+: do-drag ( thumb -- )
+ find-slider {
+ [ orientation>> drag-loc vdot ]
+ [ screen>slider ]
+ [ saved>> + ]
+ [ model>> set-range-value ]
+ } cleave ;
+
+thumb H{
+ { T{ button-down } [ begin-drag ] }
+ { T{ button-up } [ drop ] }
+ { T{ drag } [ do-drag ] }
+} set-gestures
+
+CONSTANT: horizontal-thumb-tiles
+ {
+ { "horizontal-scroller-handle-left" f }
+ { "horizontal-scroller-handle-middle" 1/2 }
+ { "horizontal-scroller-handle-grip" f }
+ { "horizontal-scroller-handle-middle" 1/2 }
+ { "horizontal-scroller-handle-right" f }
+ }
+
+CONSTANT: vertical-thumb-tiles
+ {
+ { "vertical-scroller-handle-top" f }
+ { "vertical-scroller-handle-middle" 1/2 }
+ { "vertical-scroller-handle-grip" f }
+ { "vertical-scroller-handle-middle" 1/2 }
+ { "vertical-scroller-handle-bottom" f }
+ }
+
+: build-thumb ( thumb -- thumb )
+ dup orientation>> {
+ { horizontal [ horizontal-thumb-tiles ] }
+ { vertical [ vertical-thumb-tiles ] }
+ } case
+ [ [ theme-image <icon> ] dip track-add ] assoc-each ;
+
+: <thumb> ( orientation -- thumb )
+ thumb new-track
+ 0 >>fill
+ 1/2 >>align
+ build-thumb
+ t >>root? ;
+
+: compute-direction ( elevator -- -1/1 )
+ [ hand-click-rel ] [ find-slider ] bi
+ [ orientation>> vdot ]
+ [ screen>slider ]
+ [ slider-value - sgn ]
+ tri ;
+
+: elevator-hold ( elevator -- )
+ [ direction>> ] [ find-slider ] bi '[ _ slide-by-page ] when* ;
+
+: elevator-click ( elevator -- )
+ dup compute-direction >>direction
+ elevator-hold ;
+
+elevator H{
+ { T{ drag } [ elevator-hold ] }
+ { T{ button-down } [ elevator-click ] }
+} set-gestures
+
+: <elevator> ( vector -- elevator )
+ elevator new
+ swap >>orientation ;
+
+: thumb-loc ( slider -- loc )
+ [ slider-value ]
+ [ slider-min - ]
+ [ slider>screen elevator-padding + ] tri ;
+
+: layout-thumb-loc ( thumb slider -- )
+ [ thumb-loc ] [ orientation>> ] bi n*v vfloor >>loc drop ;
+
+: layout-thumb-dim ( thumb slider -- )
+ [ dim>> ] [ thumb-dim ] [ orientation>> ] tri [ n*v ] keep set-axis
+ vceiling >>dim drop ;
+
+: slider-enabled? ( slider -- ? )
+ visible-portion 1 = not ;
+
+: layout-thumb ( slider -- )
+ [ thumb>> ] keep
+ [ slider-enabled? >>visible? drop ]
+ [ layout-thumb-loc ]
+ [ layout-thumb-dim ]
+ 2tri ;
+
+M: elevator layout*
+ find-slider layout-thumb ;
+
+: add-thumb-to-elevator ( object -- object )
+ [ elevator>> ] [ thumb>> ] bi add-gadget ;
+
+: <slide-button-pen> ( orientation left right -- pen )
+ [ horizontal = ] 2dip ?
+ [ f f ] [ theme-image <image-pen> f f ] bi* <button-pen> ;
+
+TUPLE: slide-button < repeat-button ;
+
+: <slide-button> ( orientation amount left right -- button )
+ [ swap ] 2dip
+ [
+ [ <gadget> ] dip
+ '[ _ swap find-slider slide-by-line ]
+ slide-button new-button
+ ] 3dip
+ <slide-button-pen> >>interior ;
+
+M: slide-button pref-dim* dup interior>> pen-pref-dim ;
+
+: <up-button> ( orientation -- button )
+ -1
+ "horizontal-scroller-leftarrow-clicked"
+ "vertical-scroller-uparrow-clicked"
+ <slide-button> ;
+
+: <down-button> ( orientation -- button )
+ 1
+ "horizontal-scroller-rightarrow-clicked"
+ "vertical-scroller-downarrow-clicked"
+ <slide-button> ;
+
+TUPLE: slider-pen enabled disabled ;
+
+: <slider-pen> ( orientation -- pen )
+ {
+ { horizontal [
+ "horizontal-scroller-left" theme-image
+ "horizontal-scroller-middle" theme-image
+ "horizontal-scroller-right" theme-image
+ "horizontal-scroller-right-disabled" theme-image
+ ] }
+ { vertical [
+ "vertical-scroller-top" theme-image
+ "vertical-scroller-middle" theme-image
+ "vertical-scroller-bottom" theme-image
+ "vertical-scroller-bottom-disabled" theme-image
+ ] }
+ } case
+ [ f f <tile-pen> ] bi-curry@ 2bi slider-pen boa ;
+
+: current-pen ( slider pen -- pen )
+ [ slider-enabled? ] [ [ enabled>> ] [ disabled>> ] bi ] bi* ? ;
+
+M: slider-pen draw-interior
+ dupd current-pen draw-interior ;
+
+M: slider-pen draw-boundary
+ dupd current-pen draw-boundary ;
+
+M: slider-pen pen-pref-dim
+ enabled>> pen-pref-dim ;
+
+M: slider pref-dim*
+ [ dup slider-enabled? [ dup interior>> pen-pref-dim ] [ drop { 0 0 } ] if ]
+ [ drop { 100 100 } ]
+ [ orientation>> ] tri set-axis ;
+
+PRIVATE>
+
+: <slider> ( range orientation -- slider )
+ slider new-track
+ swap >>model
+ 16 >>line
+ dup orientation>> {
+ [ <slider-pen> >>interior ]
+ [ <thumb> >>thumb ]
+ [ <elevator> >>elevator ]
+ [ drop dup add-thumb-to-elevator 1 track-add ]
+ [ <up-button> f track-add ]
+ [ <down-button> f track-add ]
+ [ drop <gadget> { 1 1 } >>dim f track-add ]
+ } cleave ;
+
+! skov
+! : <slider> ( range orientation -- slider )
+! slider new-track
+! swap >>model
+! 16 >>line
+! dup orientation>> {
+! [ <thumb> >>thumb ]
+! [ <elevator> >>elevator ]
+! [ drop dup add-thumb-to-elevator 1 track-add ]
+! } cleave ;
+
+! M: slider pref-dim*
+! [ slider-enabled? [ { 16 16 } ] [ { 0 0 } ] if ]
+! [ drop { 0 0 } ]
+! [ orientation>> ] tri set-axis ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs cache combinators images images.loader
+kernel math namespaces opengl opengl.textures sequences
+splitting system ui.gadgets.worlds vocabs math.vectors colors ;
+IN: ui.images
+
+TUPLE: image-name path ;
+
+C: <image-name> image-name
+
+<PRIVATE
+
+MEMO: cached-image-path ( path -- image )
+ [ load-image ] [ "@2x" subseq-of? >>2x? ] bi ;
+
+PRIVATE>
+
+GENERIC: cached-image ( image -- image )
+
+M: image-name cached-image
+ path>> gl-scale-factor get-global [ 1.0 > ] [ f ] if* [
+ "." split1-last "@2x." glue
+ ] when cached-image-path ;
+
+M: image cached-image ;
+
+<PRIVATE
+
+: image-texture-cache ( world -- texture-cache )
+ [ [ <cache-assoc> ] unless* ] change-images images>> ;
+
+PRIVATE>
+
+: rendered-image ( image -- texture )
+ world get image-texture-cache
+ [ cached-image { 0 0 } <texture> ] cache ;
+
+: draw-image ( image -- )
+ rendered-image draw-texture ;
+
+: draw-scaled-image ( dim image -- )
+ rendered-image draw-scaled-texture ;
+
+! : image-dim ( image -- dim )
+! cached-image [ dim>> ] [ 2x?>> [ [ 2 / ] map ] when ] bi ;
+
+! skov
+: image-dim ( image-name -- dim )
+ cached-image dim>> 1/2 v*n ;
+
+{
+ { [ os macosx? ] [ "images.loader.cocoa" require ] }
+ { [ os windows? ] [ "images.loader.gdiplus" require ] }
+ { [ os { freebsd } member? ] [
+ "images.png" require
+ "images.tiff" require
+ ] }
+ [ "images.loader.gtk" require ]
+} cond
--- /dev/null
+USING: accessors arrays assocs colors combinators
+combinators.short-circuit combinators.smart kernel locals math
+math.functions math.order ranges math.vectors opengl.gl
+sequences ui.gadgets ui.gadgets.packs ui.pens ui.pens.caching
+ui.pens.gradient system ;
+IN: ui.pens.gradient-rounded
+
+TUPLE: gradient-shape < caching-pen colors foreground shape last-vertices last-colors ;
+TUPLE: gradient-squircle < gradient-shape ;
+TUPLE: gradient-arrow < gradient-shape ;
+TUPLE: gradient-pointy < gradient-shape ;
+TUPLE: gradient-dynamic-shape < gradient-shape selected? ;
+
+: <gradient-squircle> ( colors foreground -- gradient )
+ gradient-squircle new swap >>foreground swap >>colors ;
+
+: <gradient-arrow> ( colors foreground -- gradient )
+ gradient-arrow new swap >>foreground swap >>colors ;
+
+: <gradient-pointy> ( colors foreground -- gradient )
+ gradient-pointy new swap >>foreground swap >>colors ;
+
+: <gradient-dynamic-shape> ( colors foreground selected? -- gradient )
+ gradient-dynamic-shape new swap >>selected? swap >>foreground swap >>colors ;
+
+<PRIVATE
+
+CONSTANT: tau 6.283185307179586
+CONSTANT: points 100
+
+: squircle-point ( theta -- xy )
+ [ cos ] [ sin ] bi [ [ abs sqrt ] [ sgn ] bi * 0.5 * 0.5 + ] bi@ 2array ;
+
+:: tan-point ( y slope -- xy )
+ y tau * 4 / tan 300 / 0.5 min y slope / + y 2array ;
+
+:: squircle ( -- seq )
+ 1/4 tau * 3/4 tau * 1/2 tau * points / <range> [ squircle-point ] map ;
+
+:: arrow ( -- seq )
+ { { -0.25 1 } { 0 0.5 } { -0.25 0 } } ;
+
+:: wide-narrow ( slope -- seq )
+ 0.0 1.0 1 points / <range> [ slope tan-point ] map reverse ;
+
+: narrow-wide ( slope -- seq )
+ wide-narrow unzip [ reverse ] dip zip ;
+
+:: wide-narrow-wide ( slope -- seq )
+ slope wide-narrow unzip drop slope narrow-wide unzip [ [ min ] 2map ] dip zip ;
+
+:: narrow-wide-narrow ( slope -- seq )
+ slope wide-narrow unzip drop slope narrow-wide unzip [ [ max ] 2map ] dip zip ;
+
+:: vertices ( dim left-shape right-shape symmetric? -- seq )
+ dim first2 :> ( x y )
+ left-shape right-shape [ call( -- seq ) [ y v*n ] map ] bi@
+ reverse symmetric? [ [ first2 [ neg ] dip 2array ] map ] unless
+ [ first2 swap x swap - swap 2array ] map append
+ x 2 / y 2 / 2array prefix dup second suffix ;
+
+:: interp-color ( x colors -- seq )
+ colors [ >rgba-components 4array ] map first2 zip [ first2 dupd - x * - ] map ;
+
+:: vertices-colors ( dim seq colors -- seq )
+ seq [ second dim second / colors interp-color ] map ;
+
+: draw-triangle-fan ( vertices colors -- )
+ GL_TRIANGLE_FAN glBegin
+ [ first3 glColor3f first2 glVertex2f ] 2each
+ glEnd ;
+
+:: gradient-start ( edge center -- s )
+ center first2 :> ( xc yc )
+ edge first2 :> ( xe ye )
+ 8 xe xc - sq ye yc - sq + sqrt / :> alpha
+ xe xe xc - alpha * -
+ ye ye yc - alpha * - 8 max 16 min 2array ;
+
+: draw-triangle-fan-selected ( vertices -- )
+ unclip dupd [ gradient-start ] curry map
+ GL_TRIANGLE_STRIP glBegin
+ [ 1.0 1.0 1.0 0.0 glColor4f first2 glVertex2f
+ 1.0 1.0 1.0 0.6 glColor4f first2 glVertex2f ] 2each
+ glEnd ;
+
+: left ( gadget -- dim ) screen-loc first ;
+: right ( gadget -- dim ) [ screen-loc first ] [ dim>> first ] bi + ;
+
+: default-value ( side -- x )
+ \ left = 10000 0 ? ;
+
+: compare ( x y side -- ? )
+ \ left = [ 3 - < ] [ 3 + > ] if ;
+
+:: above ( gadget side -- dim )
+ gadget parent>> gadget-child children>> [ empty? not ]
+ [ side \ left = [ first ] [ last ] if children>> second side execute( x -- x ) ]
+ [ side default-value ] smart-if* ;
+
+:: below ( gadget side -- dim )
+ gadget parent>> parent>>
+ [ dup parent>> children>> { [ length 1 > nip ] [ second = not ] } 2&& ]
+ [ parent>> children>> second side execute( x -- x ) ]
+ [ side default-value ] smart-if* ;
+
+:: above-wider? ( gadget side -- ? )
+ gadget [ side above ] [ side execute( x -- x ) ] bi side compare ;
+
+:: below-wider? ( gadget side -- ? )
+ gadget [ side below ] [ side execute( x -- x ) ] bi side compare ;
+
+:: find-half-shape ( gadget side -- shape ) {
+ { [ gadget left 10 < ] [ [ squircle ] ] }
+ { [ gadget side above-wider? gadget side below-wider? and ] [ [ 6 wide-narrow-wide ] ] }
+ { [ gadget side above-wider? gadget side below-wider? not and ] [ [ 6 wide-narrow ] ] }
+ { [ gadget side above-wider? not gadget side below-wider? and ] [ [ 6 narrow-wide ] ] }
+ { [ gadget side above-wider? not gadget side below-wider? not and ] [ [ 6 narrow-wide-narrow ] ] }
+ } cond ;
+
+: find-shape ( gadget -- left-shape right-shape )
+ [ \ left find-half-shape ] [ \ right find-half-shape ] bi ;
+
+:: (recompute-pen) ( gadget gradient left-shape right-shape symmetric? -- )
+ gadget dim>> dup left-shape right-shape symmetric? vertices dup gradient last-vertices<<
+ gradient colors>> vertices-colors gradient last-colors<< ;
+
+M: gradient-squircle recompute-pen ( gadget gradient -- )
+ [ squircle ] dup t (recompute-pen) ;
+
+M: gradient-arrow recompute-pen ( gadget gradient -- )
+ [ arrow ] dup f (recompute-pen) ;
+
+M: gradient-pointy recompute-pen ( gadget gradient -- )
+ [ 1.5 narrow-wide-narrow ] dup t (recompute-pen) ;
+
+M:: gradient-dynamic-shape recompute-pen ( gadget gradient -- )
+ gadget gradient gadget find-shape t (recompute-pen) ;
+
+PRIVATE>
+
+M: gradient-shape draw-interior
+ [ compute-pen ]
+ [ last-vertices>> ]
+ [ last-colors>> draw-triangle-fan ] tri ;
+
+M: gradient-shape pen-background
+ 2drop transparent ;
+
+M: gradient-shape pen-foreground
+ nip foreground>> ;
+
+M: gradient-dynamic-shape draw-interior
+ [ call-next-method ]
+ [ selected?>> ]
+ [ last-vertices>> ] tri
+ [ draw-triangle-fan-selected ] curry when ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math opengl sequences ui.images ui.pens colors ;
+IN: ui.pens.image
+
+! Image pen
+TUPLE: image-pen image fill? ;
+
+: <image-pen> ( image -- pen ) f image-pen boa ;
+
+M: image-pen draw-interior
+ [ dim>> ] [ [ image>> ] [ fill?>> ] bi ] bi*
+ [ draw-scaled-image ] [
+ [ image-dim [ - 2 /i ] 2map ] keep
+ '[ _ draw-image ] with-translation
+ ] if ;
+
+M: image-pen pen-pref-dim nip image>> image-dim ;
+
+M: image-pen pen-background
+ 2drop transparent ;
--- /dev/null
+! Copyright (C) 2006, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes combinators
+combinators.short-circuit compiler.units debugger fonts help
+help.apropos help.crossref help.home help.markup help.stylesheet
+help.topics io.styles kernel literals make math math.vectors
+models namespaces sequences sets system ui ui.commands
+ui.gadgets ui.gadgets.borders ui.gadgets.editors
+ui.gadgets.glass ui.gadgets.panes ui.gadgets.scrollers
+ui.gadgets.status-bar ui.gadgets.toolbar ui.gadgets.tracks
+ui.gadgets.viewports ui.gadgets.worlds ui.gestures ui.pens.solid
+ui.theme ui.tools.browser.history ui.tools.browser.popups
+ui.tools.common unicode vocabs ui.gadgets.buttons.activate ;
+IN: ui.tools.browser
+
+TUPLE: browser-gadget < tool history scroller search-field popup ;
+
+browser-gadget default-font-size { 54 58 } n*v set-tool-dim
+
+M: browser-gadget history-value
+ [ control-value ] [ scroller>> scroll-position ]
+ bi 2array ;
+
+M: browser-gadget set-history-value
+ [ first2 ] dip
+ [ set-control-value ] [ scroller>> set-scroll-position ]
+ bi-curry bi* ;
+
+: show-help ( link browser-gadget -- )
+ [ >link ] dip
+ [
+ 2dup control-value =
+ [ 2drop ] [ [ add-recent ] [ history>> add-history ] bi* ] if
+ ]
+ [ set-control-value ]
+ 2bi ;
+
+CONSTANT: prev -1
+CONSTANT: next 1
+
+: add-navigation-arrow ( str direction -- str )
+ prev = [ "←" prefix ] [ "→" suffix ] if ;
+
+: $navigation-arrow ( content element direction -- )
+ [ prefix 1array ] dip add-navigation-arrow , ;
+
+:: $navigation ( topic direction -- )
+ help-path-style get [
+ topic [
+ direction prev/next-article
+ [ 1array \ $long-link direction $navigation-arrow ] when*
+ ] { } make [ ($navigation-table) ] unless-empty
+ ] with-style ;
+
+: $title ( topic -- )
+ title-style get clone page-color over delete-at
+ [
+ [ ($title) ]
+ [ ($navigation-path) ] bi
+ ] with-nesting ;
+
+! : <help-header> ( browser-gadget -- gadget )
+! model>> [ '[ _ $title ] try ] <pane-control> ;
+
+! skov
+: <help-header> ( browser-gadget -- gadget )
+ horizontal <track> swap model>>
+ [ [ '[ _ $title ] try ] <pane-control> 1 track-add ]
+ [ <active/inactive> { 5 0 } <border> f track-add ] bi ;
+
+: add-help-header ( track -- track )
+ dup <help-header> { 3 3 } <border>
+ help-header-background <solid> >>interior
+ { 1 0 } >>fill f track-add ;
+
+: <help-footer> ( browser-gadget direction -- gadget )
+ [ model>> ] dip '[ [ _ $navigation ] try ] <pane-control>
+ { 0 0 } <border> { 1/2 1/2 } >>align
+ toolbar-background <solid> >>interior ;
+
+: add-help-footer ( track -- track )
+ horizontal <track> with-lines
+ dupd swap prev <help-footer> 1 track-add
+ dupd swap next <help-footer> 1 track-add
+ f track-add ;
+
+: print-topic ( topic -- )
+ >link
+ last-element off
+ article-content print-content ;
+
+: <help-pane> ( browser-gadget -- gadget )
+ model>> [ '[ _ print-topic ] try ] <pane-control> ;
+
+: add-help-pane ( track -- track )
+ dup dup <help-pane> margins
+ <scroller> >>scroller scroller>> white-interior 1 track-add ;
+
+: search-browser ( string browser -- )
+ '[ [ blank? ] trim <apropos-search> _ show-help ] unless-empty ;
+
+: <search-field> ( browser -- field )
+ '[ _ search-browser ] <action-field>
+ "Search" >>default-text
+ 10 >>min-cols
+ 10 >>max-cols
+ white-interior ;
+
+: <browser-toolbar> ( browser -- toolbar )
+ [ <toolbar> ] [
+ search-field>> horizontal <track>
+ 0 >>fill swap 1 track-add
+ 1 track-add
+ ] bi ;
+
+: add-browser-toolbar ( track -- track )
+ dup <browser-toolbar> format-toolbar f track-add ;
+
+: <browser-gadget> ( link -- gadget )
+ vertical browser-gadget new-track with-lines
+ 1 >>fill
+ swap >link <model> >>model
+ dup <history> >>history
+ dup <search-field> >>search-field
+ add-browser-toolbar
+ add-help-header
+ add-help-pane
+ add-help-footer ;
+
+M: browser-gadget graft*
+ [ add-definition-observer ] [ call-next-method ] bi ;
+
+M: browser-gadget ungraft*
+ [ call-next-method ] [ remove-definition-observer ] bi ;
+
+M: browser-gadget handle-gesture
+ {
+ { [ over key-gesture? not ] [ call-next-method ] }
+ { [ dup popup>> ] [ { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
+ [ call-next-method ]
+ } cond ;
+
+: showing-definition? ( defspec set -- ? )
+ {
+ [ in? ]
+ [ [ dup word-link? [ name>> ] when ] dip in? ]
+ [ [ dup vocab-link? [ lookup-vocab ] when ] dip in? ]
+ } 2|| ;
+
+M: browser-gadget definitions-changed
+ [ control-value swap showing-definition? ] keep
+ '[ _ [ history-value ] keep set-history-value ] when ;
+
+M: browser-gadget focusable-child* search-field>> ;
+
+: (browser-window) ( topic -- )
+ <browser-gadget>
+ <world-attributes>
+ "Browser" >>title
+ open-status-window ;
+
+! skov
+! : (browser-window) ( topic -- )
+! <browser-gadget>
+! <world-attributes>
+! "Browser" >>title
+! { windowed double-buffered multisampled
+! T{ samples f 4 } T{ sample-buffers f 1 } }
+! >>pixel-format-attributes
+! open-status-window ;
+
+: browser-window ( -- )
+ "help.home" (browser-window) ;
+
+: error-help-window ( error -- )
+ {
+ [ error-help ]
+ [ dup tuple? [ class-of ] [ drop "errors" ] if ]
+ } 1|| (browser-window) ;
+
+\ browser-window H{ { +nullary+ t } } define-command
+
+: com-browse ( link -- )
+ [ browser-gadget? ] find-window
+ [ [ raise-window ] [ gadget-child show-help ] bi ]
+ [ (browser-window) ] if* ;
+
+: show-browser ( -- )
+ [ browser-gadget? ] find-window
+ [ [ raise-window ] [ request-focus ] bi ] [ browser-window ] if* ;
+
+\ show-browser H{ { +nullary+ t } } define-command
+
+: com-back ( browser -- ) history>> go-back ;
+
+: com-forward ( browser -- ) history>> go-forward ;
+
+: browser-focus-search ( browser -- ) search-field>> request-focus ;
+
+: com-home ( browser -- ) "help.home" swap show-help ;
+
+: browser-help ( -- ) "ui-browser" com-browse ;
+
+: glossary ( -- ) "conventions" com-browse ;
+
+\ browser-help H{ { +nullary+ t } } define-command
+\ glossary H{ { +nullary+ t } } define-command
+
+browser-gadget "toolbar" f {
+ { T{ key-down f ${ os macosx? M+ A+ ? } "LEFT" } com-back }
+ { T{ key-down f ${ os macosx? M+ A+ ? } "RIGHT" } com-forward }
+ { T{ key-down f ${ os macosx? M+ A+ ? } "HOME" } com-home }
+ { T{ key-down f f "F1" } browser-help }
+ { T{ key-down f ${ os macosx? M+ A+ ? } "F1" } glossary }
+} define-command-map
+
+: ?show-help ( link browser -- )
+ over [ show-help ] [ 2drop ] if ;
+
+: navigate ( browser quot -- )
+ '[ control-value @ ] keep ?show-help ; inline
+
+: com-up ( browser -- ) [ article-parent ] navigate ;
+
+: com-prev ( browser -- ) [ prev-article ] navigate ;
+
+: com-next ( browser -- ) [ next-article ] navigate ;
+
+browser-gadget "navigation" "Commands for navigating in the article hierarchy" {
+ { T{ key-down f ${ os macosx? M+ A+ ? } "UP" } com-up }
+ { T{ key-down f ${ os macosx? M+ A+ ? } "p" } com-prev }
+ { T{ key-down f ${ os macosx? M+ A+ ? } "n" } com-next }
+ { T{ key-down f ${ os macosx? M+ A+ ? } "k" } com-show-outgoing-links }
+ { T{ key-down f ${ os macosx? M+ A+ ? } "K" } com-show-incoming-links }
+ { T{ key-down f ${ os macosx? M+ A+ ? } "f" } browser-focus-search }
+} os macosx? [ {
+ { T{ key-down f { M+ } "[" } com-back }
+ { T{ key-down f { M+ } "]" } com-forward }
+} append ] when define-command-map
+
+browser-gadget "multi-touch" f {
+ { left-action com-back }
+ { right-action com-forward }
+} define-command-map
+
+browser-gadget "touchbar" f {
+ { f com-back }
+ { f com-forward }
+ { f com-home }
+ { f browser-help }
+ { f glossary }
+} define-command-map
+
+browser-gadget "scrolling"
+"The browser's scroller can be scrolled from the keyboard."
+{
+ { T{ key-down f f "UP" } com-scroll-up }
+ { T{ key-down f f "DOWN" } com-scroll-down }
+ { T{ key-down f f "PAGE_UP" } com-page-up }
+ { T{ key-down f f "PAGE_DOWN" } com-page-down }
+} define-command-map
+
+: com-font-size-plus ( browser -- )
+ 2 adjust-help-font-size model>> notify-connections ;
+
+: com-font-size-minus ( browser -- )
+ -2 adjust-help-font-size model>> notify-connections ;
+
+: com-font-size-normal ( browser -- )
+ font-size-span default-style get font-size of -
+ adjust-help-font-size model>> notify-connections ;
+
+browser-gadget "fonts" f {
+ { T{ key-down f ${ os macosx? M+ C+ ? } "+" } com-font-size-plus }
+ { T{ key-down f ${ os macosx? M+ C+ ? } "=" } com-font-size-plus }
+ { T{ key-down f ${ os macosx? M+ C+ ? } "_" } com-font-size-minus }
+ { T{ key-down f ${ os macosx? M+ C+ ? } "-" } com-font-size-minus }
+ { T{ key-down f ${ os macosx? M+ C+ ? } "0" } com-font-size-normal }
+} define-command-map
+
+MAIN: browser-window
--- /dev/null
+! Copyright (C) 2015-2017 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays code code.execution colors
+combinators combinators.short-circuit combinators.smart fry
+kernel listener locals locals math math.order math.statistics
+math.vectors models namespaces sequences splitting system
+ui.commands ui.gadgets ui.gadgets.borders
+ui.gadgets.buttons.round ui.gadgets.editors
+ui.gadgets.editors.private ui.gadgets.frames ui.gadgets.grids
+ui.gadgets.labels ui.gadgets.packs ui.gadgets.worlds ui.gestures
+ui.pens.gradient-rounded ui.pens.solid ui.pens.tile
+ui.pens.title-gradient ui.render ui.text ui.tools.browser
+ui.tools.environment.theme ;
+FROM: code => call ;
+FROM: models => change-model ;
+IN: ui.tools.environment.cell
+
+CONSTANT: cell-height 24
+CONSTANT: min-cell-width 30
+
+TUPLE: cell < border selection ;
+TUPLE: cell-editor < editor ;
+
+: <cell-editor> ( -- editor )
+ cell-editor new-editor ;
+
+: selected? ( cell -- ? )
+ [ control-value ] [ selection>> value>> [ result? ] [ parent>> ] smart-when ] bi eq? ;
+
+:: subtree-input? ( node -- ? )
+ node introduce?
+ node name>> empty? and
+ node [ quoted-node? ] find-parent and ;
+
+:: cell-colors ( cell -- bg-color text-color )
+ cell control-value
+ { { [ dup input/output? ] [ drop dark-background light-text-colour ] }
+ { [ dup text? ] [ drop white-background dark-text-colour ] }
+ { [ dup call? ] [ drop green-background dark-text-colour ] }
+ { [ dup getter? ] [ drop yellow-background dark-text-colour ] }
+ { [ dup setter? ] [ drop yellow-background dark-text-colour ] }
+ [ drop cell selected? active-background inactive-background ? light-text-colour ]
+ } cond ;
+
+:: cell-theme ( cell -- cell )
+ cell dup cell-colors
+ cell control-value name>> empty? [ faded-color ] when
+ cell selected?
+ cell control-value node? [ <gradient-dynamic-shape> ] [ <title-gradient> ] if
+ >>interior ;
+
+:: enter-name ( name cell -- cell )
+ cell control-value
+ { { [ name empty? ] [ ] }
+ { [ cell control-value call? not ] [ name >>name ] }
+ { [ cell control-value clone name >>name find-target empty? not ]
+ [ name >>name dup find-target [ length 1 > ] [ >>completion ] [ first >>target ] smart-if ] }
+ [ ]
+ } cond
+ cell set-control-value
+ cell control-value [ [ word? ] [ vocab? ] bi or ] find-parent [ ?define ] when*
+ cell selection>> notify-connections cell ;
+
+:: ?enter-name ( cell -- cell )
+ cell children>> [ editor? ] filter first editor-string dup empty?
+ [ drop cell ] [ cell enter-name ] if ;
+
+: replace-space ( char -- char )
+ [ CHAR: space = ] [ drop CHAR: ⎵ ] smart-when
+ [ CHAR: \t = ] [ drop CHAR: ⇥ ] smart-when ;
+
+: make-spaces-visible ( str -- str )
+ [ length 0 > ] [ unclip replace-space prefix ] smart-when
+ [ length 1 > ] [ unclip-last replace-space suffix ] smart-when ;
+
+: <cell> ( value selection -- node )
+ cell new { 12 0 } >>size min-cell-width cell-height 2array >>min-dim
+ swap >>selection swap <model> >>model horizontal >>orientation ;
+
+:: collapsed? ( cell -- ? )
+ cell control-value subtree-input?
+ cell selected? not and ;
+
+M:: cell model-changed ( model cell -- )
+ cell cell-colors :> text-color :> bg-color
+ cell dup clear-gadget
+ cell collapsed? [ "" ] [ model value>> name-or-default make-spaces-visible ] if
+ <label> set-font add-gadget
+ <cell-editor> f >>visible? set-font
+ [ text-color >>foreground transparent >>background ] change-font add-gadget
+ model value>> node? [
+ cell selected? model value>> parent>> and [
+ <shelf> { 5 0 } >>gap
+ inactive-background "✕"
+ [ drop model value>> remove-element cell selection>> set-model ] <round-button>
+ model value>> vocab? "Delete vocabulary" "Delete word" ? " ( Ctrl R )" append
+ >>tooltip add-gadget
+ model value>> word? [
+ inactive-background "↑"
+ [ drop model value>> left exchange-node-side cell selection>> set-model ] <round-button>
+ "Move up" >>tooltip add-gadget
+ inactive-background "↓"
+ [ drop model value>> right exchange-node-side cell selection>> set-model ] <round-button>
+ "Move down" >>tooltip add-gadget
+ ] when
+ add-gadget ] when
+ model value>> executable? [
+ cell selection>> value>> parent>> cell control-value eq? [
+ blue-background "Result"
+ [ drop model value>> cell selection>> set-model ] <round-button>
+ "Show word ( Shift Enter )" >>tooltip
+ ] [
+ inactive-background "Result"
+ [ drop model value>> dup run-word result>> cell selection>> set-model ] <round-button>
+ "Show result ( Shift Enter )" >>tooltip
+ ] if add-gadget ] when
+ ] unless cell-theme drop ;
+
+M:: cell layout* ( cell -- )
+ cell children>> first { [ editor? ] [ editor-string empty? ] } 1&&
+ cell children>> second { [ editor? ] [ editor-string empty? not ] } 1&& or
+ [ 0 1 cell children>> exchange ] when
+ cell children>> first t >>visible? drop
+ cell children>> second f >>visible? drop
+ cell call-next-method
+ cell children>> rest rest [
+ dup pack? not cell dim>> first 68 - 15 ? 5 2array >>loc
+ dup pref-dim >>dim drop
+ ] each ;
+
+M: cell focusable-child*
+ children>> [ editor? ] filter first ;
+
+M: cell graft*
+ [ selected? ] [ request-focus ] smart-when* ;
+
+M: cell pref-dim*
+ dup call-next-method swap collapsed? [ 12 over set-second ] when ;
+
+:: select-cell ( cell -- )
+ cell control-value name>> "⨁" = [
+ cell parent>> control-value [ vocab? ] find-parent
+ cell control-value "" >>name add-element drop
+ ] when
+ cell control-value cell selection>> set-model ;
+
+:: change-cell ( cell quot -- )
+ cell control-value node? [ cell selection>> quot change-model ] when ; inline
+
+:: change-cell* ( cell quot -- )
+ cell control-value node? [ cell selection>> quot change-model ] unless ; inline
+
+: convert-cell ( cell class -- )
+ [ ?change-node-type ] curry change-cell ;
+
+: show-help-on-word ( cell -- )
+ [ control-value target>>
+ [ (browser-window) ] [ show-browser ] if*
+ ] with-interactive-vocabs ;
+
+:: ask-for-completion ( cell -- )
+ cell children>> [ editor? ] filter first editor-string
+ [ cell model>> [ swap [ >>name ] [ matching-words >>completion ] bi ] with change-model
+ cell selection>> notify-connections ] unless-empty ;
+
+cell H{
+ { T{ button-down } [ select-cell ] }
+ { lose-focus [ ?enter-name drop ] }
+ { T{ key-down f f "RET" } [ ?enter-name drop ] }
+ { T{ key-down f { C+ } "w" } [ ?enter-name call convert-cell ] }
+ { T{ key-down f { C+ } "W" } [ ?enter-name call convert-cell ] }
+ { T{ key-down f { C+ } "i" } [ ?enter-name introduce convert-cell ] }
+ { T{ key-down f { C+ } "I" } [ ?enter-name introduce convert-cell ] }
+ { T{ key-down f { C+ } "o" } [ ?enter-name return convert-cell ] }
+ { T{ key-down f { C+ } "O" } [ ?enter-name return convert-cell ] }
+ { T{ key-down f { C+ } "t" } [ ?enter-name text convert-cell ] }
+ { T{ key-down f { C+ } "T" } [ ?enter-name text convert-cell ] }
+ { T{ key-down f { C+ } "s" } [ ?enter-name setter convert-cell ] }
+ { T{ key-down f { C+ } "S" } [ ?enter-name setter convert-cell ] }
+ { T{ key-down f { C+ } "g" } [ ?enter-name getter convert-cell ] }
+ { T{ key-down f { C+ } "G" } [ ?enter-name getter convert-cell ] }
+ { T{ key-down f { C+ } "r" } [ [ replace-parent ] change-cell ] }
+ { T{ key-down f { C+ } "R" } [ [ replace-parent ] change-cell ] }
+ { T{ key-down f { C+ } "d" } [ [ remove-element ] change-cell ] }
+ { T{ key-down f { C+ } "D" } [ [ remove-element ] change-cell ] }
+ { T{ key-down f { C+ } "q" } [ [ (un)quote ] change-cell ] }
+ { T{ key-down f { C+ } "Q" } [ [ (un)quote ] change-cell ] }
+ { T{ key-down f f "UP" } [ ?enter-name [ child-node ] change-cell ] }
+ { T{ key-down f f "DOWN" } [ ?enter-name [ parent-node ] change-cell ] }
+ { T{ key-down f f "LEFT" } [ ?enter-name [ left side-node ] change-cell ] }
+ { T{ key-down f f "RIGHT" } [ ?enter-name [ right side-node ] change-cell ] }
+ { T{ key-down f { A+ } "LEFT" } [ ?enter-name [ left exchange-node-side ] change-cell ] }
+ { T{ key-down f { A+ } "RIGHT" } [ ?enter-name [ right exchange-node-side ] change-cell ] }
+ { T{ key-down f { M+ } "LEFT" } [ ?enter-name [ left insert-node-side ] change-cell ] }
+ { T{ key-down f { M+ } "RIGHT" } [ ?enter-name [ right insert-node-side ] change-cell ] }
+ { T{ key-down f { M+ } "DOWN" } [ ?enter-name [ insert-new-parent ] change-cell ] }
+ { T{ key-down f { C+ } "h" } [ show-help-on-word ] }
+ { T{ key-down f { C+ } "H" } [ show-help-on-word ] }
+ { T{ key-down f f "TAB" } [ ask-for-completion ] }
+ { T{ key-down f f "ESC" } [ [ parent-node ] change-cell* ] }
+} set-gestures
+
+: previous-character* ( editor -- )
+ [ editor-caret second 0 = ]
+ [ parent>> ?enter-name [ left side-node ] change-cell ]
+ [ previous-character ] smart-if ;
+
+: next-character* ( editor -- )
+ [ [ editor-caret second ] [ editor-string length ] bi = ]
+ [ parent>> ?enter-name [ right side-node ] change-cell ]
+ [ next-character ] smart-if ;
+
+cell-editor "caret-motion" f {
+ { T{ key-down f f "LEFT" } previous-character* }
+ { T{ key-down f f "RIGHT" } next-character* }
+} define-command-map
--- /dev/null
+! Copyright (C) 2015-2017 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel memory models namespaces ui ui.gadgets
+ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.tracks
+ui.gadgets.worlds ui.gestures ui.pixel-formats ui.tools.browser
+ui.tools.common ;
+FROM: models => change-model ;
+IN: ui.tools.environment
+
+TUPLE: environment < tool ;
+
+environment { 700 600 } set-tool-dim
+
+:: <environment> ( -- gadget )
+ skov-root get-global <model> :> model
+ vertical environment new-track model >>model
+ model <navigation> <scroller> 1 track-add
+ with-background ;
+
+: environment-window ( -- )
+ [ <environment>
+ <world-attributes>
+ { windowed double-buffered multisampled
+ T{ samples f 4 } T{ sample-buffers f 1 } }
+ >>pixel-format-attributes
+ "Skov" >>title open-status-window ] with-ui ;
+
+: save-image-and-vocabs ( env -- )
+ drop save export-vocabs ;
+
+: load-vocabs ( env -- )
+ update-skov-root skov-root get-global swap set-control-value ;
+
+environment H{
+ { T{ key-down f { C+ } "h" } [ drop show-browser ] }
+ { T{ key-down f { C+ } "H" } [ drop show-browser ] }
+ { save-action [ save-image-and-vocabs ] }
+ { open-action [ load-vocabs ] }
+} set-gestures
--- /dev/null
+! Copyright (C) 2015-2017 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays accessors colors kernel locals math math.constants
+math.functions opengl.gl sequences ui.gadgets system
+ui.render ui.tools.environment.theme ;
+IN: ui.tools.environment.navigation.dot-pattern
+
+TUPLE: dot-pattern < gadget ;
+
+: <dot-pattern> ( child -- gadget )
+ dot-pattern new swap add-gadget ;
+
+CONSTANT: dr 8
+
+:: draw-dot-ring ( x y n -- )
+ n 6 * <iota> [
+ tau * 6 n * /
+ [ sin n * dr * x 2 /i + dup [ 3 > ] [ x 3 - < ] bi and ]
+ [ cos n * dr * 44 + dup [ 3 > ] [ y 3 - < ] bi and ] bi
+ swapd and [ glVertex2f ] [ drop drop ] if
+ ] each ;
+
+M: dot-pattern draw-gadget*
+ os windows? [ drop ] [
+ dim>> [ first2 ] [ first 2 / dr /i ] bi
+ GL_POINT_SMOOTH glEnable
+ 9 glPointSize
+ GL_POINTS glBegin
+ blue-background second >rgba-components drop 0.12 glColor4f
+ <iota> [ draw-dot-ring ] 2with each
+ glEnd
+ ] if ;
+
+M: dot-pattern pref-dim*
+ drop { 0 65 } ;
+
+M: dot-pattern layout*
+ [ dim>> first ] [ gadget-child ] bi dup pref-dim second
+ swapd 2array >>dim { 0 23 } >>loc drop ;
--- /dev/null
+! Copyright (C) 2015-2017 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors code code.execution colors combinators
+combinators.smart kernel locals models sequences system
+ui.gadgets ui.gadgets.borders ui.gadgets.buttons
+ui.gadgets.buttons.round ui.gadgets.icons ui.gadgets.labels
+ui.gadgets.packs ui.gestures ui.pens.gradient-rounded
+ui.pens.tile ui.tools.environment.cell ui.tools.environment.tree
+ui.tools.environment.navigation.dot-pattern
+ui.tools.environment.theme ui.tools.environment ;
+FROM: models => change-model ;
+IN: ui.tools.environment.navigation
+
+TUPLE: navigation < pack ;
+
+: <category> ( background name -- gadget )
+ <label>
+ [ t >>bold? ] change-font { 26 0 } <border>
+ swap dark-text-colour <gradient-pointy> >>interior
+ { 0 22 } >>min-dim horizontal >>orientation ;
+
+: <name-bar> ( vocab/word selection -- gadget )
+ <cell> { 0 30 } >>min-dim ;
+
+: <navigation> ( model -- navigation )
+ navigation new swap >>model vertical >>orientation 1 >>fill ;
+
+:: new-item ( navigation class -- )
+ navigation control-value [ vocab? ] find-parent
+ class add-from-class contents>> last navigation set-control-value ;
+
+: find-navigation ( gadget -- navigation )
+ [ navigation? ] find-parent ;
+
+: set-children-font ( gadget -- gadget )
+ dup children>> [ [ label? ] [ set-result-font drop ] [ set-children-font drop ] smart-if ] each ;
+
+M:: navigation model-changed ( model gadget -- )
+ gadget dup clear-gadget
+ model value>> parents [ vocab? ] filter reverse
+ dup last :> voc
+ [ model <name-bar> ] map add-gadgets
+ blue-background "Vocabularies" <category> { 0 10 } <border> <dot-pattern> add-gadget
+ voc contents>> [ vocab? ] filter vocab new "⨁" >>name suffix [ model <name-bar> ] map add-gadgets
+ green-background "Words" <category> { 0 10 } <border> <dot-pattern> add-gadget
+ voc contents>> [ word? ] filter word new "⨁" >>name suffix [
+ [ model <name-bar> add-gadget ]
+ [ [ model value>> eq? ]
+ [ <tree-editor> { 10 15 } <border> add-gadget ] smart-when* ]
+ [ [ model value>> parent>> eq? model value>> result? and ]
+ [ result>> contents>> set-children-font { 10 45 } <border> add-gadget ] smart-when* ] tri
+ ] each drop ;
+
+: toggle-result ( nav -- )
+ model>> [ {
+ { [ dup executable? ] [ dup run-word result>> ] }
+ { [ dup result? ] [ parent>> ] }
+ [ ]
+ } cond ] change-model ;
+
+navigation H{
+ { T{ key-down f { C+ } "v" } [ vocab new-item ] }
+ { T{ key-down f { C+ } "V" } [ vocab new-item ] }
+ { T{ key-down f { C+ } "n" } [ word new-item ] }
+ { T{ key-down f { C+ } "N" } [ word new-item ] }
+ { T{ key-down f { S+ } "UP" } [ model>> [ [ result? not ] find-parent left side-node ] change-model ] }
+ { T{ key-down f { S+ } "DOWN" } [ model>> [ [ result? not ] find-parent right side-node ] change-model ] }
+ { T{ key-down f { S+ } "RET" } [ toggle-result ] }
+} set-gestures
--- /dev/null
+! Copyright (C) 2015 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs colors kernel math math.parser sequences
+sorting sorting.human ui.pens.solid ;
+IN: ui.tools.environment.theme
+
+CONSTANT: content-background-colour COLOR: #002b36
+
+CONSTANT: dark-background { COLOR: light-gray COLOR: dark-gray }
+CONSTANT: green-background { COLOR: gray68 COLOR: gray4 }
+CONSTANT: white-background { COLOR: gray2 COLOR: gray2 }
+CONSTANT: blue-background { COLOR: solarized-base02 COLOR: gray6 }
+CONSTANT: red-background { COLOR: DodgerBlue4 COLOR: gray6 }
+CONSTANT: yellow-background { COLOR: gray5 COLOR: gray4 }
+CONSTANT: inactive-background { COLOR: dark-green COLOR: FactorDarkGreen }
+CONSTANT: active-background { COLOR: DeepSkyBlue4 COLOR: dark-green }
+
+CONSTANT: content-text-colour COLOR: solarized-base02
+CONSTANT: dark-text-colour COLOR: black
+CONSTANT: light-text-colour COLOR: gray2
+CONSTANT: faded-text-colour COLOR: gray2
+
+: set-small-font ( label -- label )
+ [ 13 >>size t >>bold? ] change-font ;
+
+: set-font ( label -- label )
+ [ 15 >>size t >>bold? ] change-font ;
+
+: set-result-font ( label -- label )
+ [ 17 >>size t >>bold? content-text-colour >>foreground ] change-font ;
+
+: faded-color ( rgba -- rgba )
+ >rgba-components drop 0.4 <rgba> ;
+
+: with-background ( gadget -- gadget )
+ content-background-colour <solid> >>interior ;
+
+
--- /dev/null
+! Copyright (C) 2016-2017 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: code code.factor-abstraction continuations kernel models
+ui.gadgets.borders ui.gadgets.labels ui.tools.environment.tree words ;
+
+IN: ui.tools.environment.tree.help-tree
+
+: <help-tree> ( factor-word -- gadget )
+ word new swap call-from-factor add-element
+ <model> <tree> { 20 10 } <filled-border> ;
+
+: <definition-tree> ( factor-word -- gadget )
+ [ word-from-factor <model> <tree> { 5 5 } <border> ]
+ [ drop drop "(cannot be displayed)" <label> ] recover ;
--- /dev/null
+! Copyright (C) 2015-2017 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays code combinators.short-circuit kernel
+locals math math.order math.vectors models sequences splitting
+ui.gadgets ui.gadgets.borders ui.gadgets.buttons.round
+ui.gadgets.labels ui.gadgets.packs ui.gadgets.packs.private
+ui.gestures ui.pens.gradient-rounded ui.pens.solid
+ui.tools.environment.cell ui.tools.environment.tree ui.tools.environment.theme ;
+FROM: code => call ;
+FROM: models => change-model ;
+IN: ui.tools.environment.tree
+
+TUPLE: tree < pack ;
+TUPLE: tree-control < pack ;
+TUPLE: tree-toolbar < tree-control ;
+TUPLE: path-display < tree-control selected ;
+TUPLE: special-pile < pack ;
+TUPLE: path-item < pack word ;
+TUPLE: path-cell < border word? ;
+
+: <special-pile> ( -- pack )
+ special-pile new vertical >>orientation ;
+
+: center-point ( gadget -- x )
+ [ [ parent>> loc>> ] [ loc>> ] bi v+ ] [ dim>> ] bi [ first ] bi@ 2 /i + ;
+
+M:: special-pile layout* ( pack -- )
+ pack call-next-method
+ pack children>> first2 :> ( shelf cell )
+ shelf layout
+ shelf children>> empty? [
+ shelf children>> [ first ] [ last ] bi [ children>> last center-point ] bi@ :> ( a b )
+ cell pref-dim first2 [ b a - 20 + max ] dip 2array cell dim<<
+ a b + 2 /i cell dim>> first 2 /i - dup neg?
+ [ neg shelf loc>> second 2array shelf loc<< ]
+ [ cell loc>> second 2array cell loc<< ] if
+ ] unless ;
+
+: <quoted-cell> ( cell -- pile )
+ <special-pile> <shelf> rot add-gadget add-gadget <gadget> { 0 6 } >>dim add-gadget ;
+
+:: build-tree ( node selection -- pile )
+ <special-pile> { 0 1 } >>gap
+ <shelf> { 8 0 } >>gap 1 >>align
+ node contents>> [ selection build-tree ] map add-gadgets add-gadget
+ node selection <cell> add-gadget
+ node quoted?>> [ <quoted-cell> ] when ;
+
+: <tree> ( word -- pile )
+ tree new horizontal >>orientation swap >>model { 15 0 } >>gap 1 >>align ;
+
+M:: tree model-changed ( model tree -- )
+ tree clear-gadget
+ tree model value>> [ word? ] find-parent ?add-words
+ contents>> [ model build-tree ] map add-gadgets drop ;
+
+M: tree-control pref-dim*
+ call-next-method first2 20 max 2array ;
+
+: <tree-toolbar> ( model -- gadget )
+ tree-toolbar new horizontal >>orientation { 5 0 } >>gap swap >>model ;
+
+:: add-button ( toolbar cond-quot color letter action-quot tooltip -- toolbar )
+ toolbar dup control-value cond-quot call( x -- ? )
+ [ color letter [ drop toolbar model>> action-quot change-model ] ]
+ [ inactive-background "" [ drop ] ] if <round-button>
+ tooltip >>tooltip add-gadget ;
+
+M:: tree-toolbar model-changed ( model tree-toolbar -- )
+ tree-toolbar dup clear-gadget
+ model value>> [ word? ] find-parent ?add-words drop
+ model value>> node? [
+ [ top-node? ] dark-background "I" [ introduce ?change-node-type ]
+ "Convert cell into an input cell ( Control I )" add-button
+ [ top-node? ] yellow-background "G" [ getter ?change-node-type ]
+ "Convert cell into a get cell ( Control G )" add-button
+ [ top-node? ] white-background "T" [ text ?change-node-type ]
+ "Convert cell into a text cell ( Control T )" add-button
+ <gadget> add-gadget
+ [ drop t ] green-background "W" [ call ?change-node-type ]
+ "Convert cell into a word cell ( Control W )" add-button
+ <gadget> add-gadget
+ [ bottom-node? ] yellow-background "S" [ setter ?change-node-type ]
+ "Convert cell into a set cell ( Control S )" add-button
+ [ [ bottom-node? ] [ no-return? ] [ return? ] tri or and ]
+ dark-background "O" [ return ?change-node-type ]
+ "Convert cell into an output cell ( Control O )" add-button
+ <gadget> { 20 0 } >>dim add-gadget
+ model value>> bottom-node?
+ [ inactive-background "" [ drop ] ]
+ [ blue-background model value>> quoted?>> "︾" "︽" ?
+ [ drop model [ (un)quote ] change-model ] ] if <round-button>
+ model value>> quoted?>> "Unquote" "Quote" ? " ( Control Q )" append
+ >>tooltip add-gadget
+ <gadget> add-gadget
+ [ leftmost-node? not ] blue-background "←" [ left exchange-node-side ]
+ "Exchange cell and cell on the left ( Command ← )" add-button
+ [ rightmost-node? not ] blue-background "→" [ right exchange-node-side ]
+ "Exchange cell and cell on the right ( Command → )" add-button
+ <gadget> add-gadget
+ [ parent>> { [ word? ] [ variadic? ] } 1|| ]
+ blue-background "⇐" [ left insert-node-side ]
+ "Insert new cell on the left ( Option ← )" add-button
+ [ parent>> { [ word? ] [ variadic? ] } 1|| ]
+ blue-background "⇒" [ right insert-node-side ]
+ "Insert new cell on the right ( Option → )" add-button
+ [ drop t ] blue-background "⇓" [ insert-new-parent ]
+ "Insert new cell below ( Option ↓ )" add-button
+ <gadget> add-gadget
+ [ bottom-node? not ] red-background "↓" [ replace-parent ]
+ "Replace cell below ( Control R )" add-button
+ [ drop t ]
+ red-background "✕" [ remove-element ]
+ "Delete cell and everything above ( Control D )" add-button
+ ] when drop ;
+
+: path-cell-colors ( cell -- bg-color text-color )
+ word?>> [ green-background dark-text-colour ]
+ [ blue-background dark-text-colour ] if ;
+
+: <path-cell> ( name word? -- node )
+ path-cell new { 5 0 } >>size { 0 18 } >>min-dim
+ swap >>word? swap " " append <label> set-small-font add-gadget
+ dup path-cell-colors <gradient-arrow> >>interior ;
+
+: <path-item> ( factor-word -- gadget )
+ dup [ vocabulary>> "." split [ f <path-cell> ] map ] [ name>> t <path-cell> ] bi suffix
+ path-item new swap add-gadgets swap >>word horizontal >>orientation { 7 0 } >>gap ;
+
+: <path-display> ( model -- gadget )
+ path-display new vertical >>orientation { 0 5 } >>gap swap >>model ;
+
+M:: path-display model-changed ( model path-display -- )
+ path-display dup clear-gadget
+ model value>> call? [
+ model value>> target>> number? [
+ model value>> completion>>
+ [ model value>> completion>> [ <path-item> ] map add-gadgets ]
+ [ model value>> target>> [ <path-item> add-gadget ] when* ] if
+ ] unless
+ ] when drop ;
+
+: <tree-editor> ( word -- gadget )
+ <pile> { 0 30 } >>gap 1/2 >>align swap <model>
+ [ <tree-toolbar> ] [ <tree> ] [ <path-display> ] tri 3array add-gadgets ;
+
+: select-nothing ( tree -- )
+ model>> [ [ node? not ] find-parent ] change-model ;
+
+: choose-word ( path-item -- )
+ [ word>> ] [ parent>> model>> ] bi
+ [ swap >>target dup target>> name>> short-name >>name f >>completion ] with change-model ;
+
+: select-word ( path-item -- )
+ dark-background second <solid> >>interior relayout-1 ;
+
+: deselect-word ( path-item -- )
+ f >>interior relayout-1 ;
+
+tree H{
+ { T{ button-down } [ select-nothing ] }
+} set-gestures
+
+path-item H{
+ { T{ button-down } [ choose-word ] }
+} set-gestures
--- /dev/null
+! Copyright (C) 2005, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs calendar combinators
+combinators.short-circuit concurrency.flags
+concurrency.mailboxes continuations destructors documents
+documents.elements fonts hashtables help help.markup help.tips
+io io.styles kernel lexer listener literals math math.vectors
+models models.arrow models.delay namespaces parser prettyprint
+sequences source-files.errors splitting strings system threads
+ui ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.glass
+ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers
+ui.gadgets.status-bar ui.gadgets.toolbar ui.gadgets.tracks
+ui.gestures ui.operations ui.pens.solid ui.theme
+ui.tools.browser ui.tools.common ui.tools.debugger
+ui.tools.error-list ui.tools.listener.completion
+ui.tools.listener.history ui.tools.listener.popups vocabs
+vocabs.loader vocabs.parser vocabs.refresh words ui.gadgets.borders
+ui.tools.environment ui.tools.environment.theme ;
+IN: ui.tools.listener
+
+TUPLE: interactor < source-editor
+ output history flag mailbox thread waiting token-model word-model popup ;
+
+INSTANCE: interactor input-stream
+
+: register-self ( interactor -- )
+ <mailbox> >>mailbox
+ self >>thread
+ drop ;
+
+: interactor-continuation ( interactor -- continuation )
+ thread>> thread-continuation ;
+
+: interactor-busy? ( interactor -- ? )
+ {
+ [ waiting>> ]
+ [ thread>> dup [ thread-registered? ] when ]
+ } 1&& not ;
+
+SLOT: manifest
+
+M: interactor manifest>>
+ dup interactor-busy? [ drop f ] [
+ interactor-continuation name>>
+ manifest swap assoc-stack
+ ] if ;
+
+GENERIC: (word-at-caret) ( token completion-mode -- obj )
+
+M: object (word-at-caret) 2drop f ;
+
+M: vocab-completion (word-at-caret)
+ drop
+ [ dup vocab-exists? [ >vocab-link ] [ drop f ] if ]
+ [ 2drop f ] recover ;
+
+M: word-completion (word-at-caret)
+ manifest>> [
+ '[ _ _ search-manifest ] [ drop f ] recover
+ ] [ drop f ] if* ;
+
+M: vocab-word-completion (word-at-caret)
+ vocab-name>> lookup-word ;
+
+: word-at-caret ( token interactor -- obj )
+ completion-mode (word-at-caret) ;
+
+: <word-model> ( interactor -- model )
+ [ token-model>> 1/3 seconds <delay> ]
+ [ '[ _ word-at-caret ] ] bi
+ <arrow> ;
+
+: <interactor> ( -- gadget )
+ interactor new-editor
+ <flag> >>flag
+ dup one-word-elt <element-model> >>token-model
+ dup <word-model> >>word-model
+ dup model>> <history> >>history ;
+
+M: interactor graft*
+ [ call-next-method ] [ dup word-model>> add-connection ] bi ;
+
+M: interactor ungraft*
+ [ dup word-model>> remove-connection ] [ call-next-method ] bi ;
+
+M: interactor model-changed
+ 2dup word-model>> eq? [
+ dup popup>>
+ [ 2drop ] [ [ value>> ] dip show-summary ] if
+ ] [ call-next-method ] if ;
+
+M: interactor stream-element-type drop +character+ ;
+
+GENERIC: (print-input) ( object -- )
+
+SYMBOL: listener-input-style
+H{
+ { font-style bold }
+ { foreground $ text-color }
+} listener-input-style set-global
+
+SYMBOL: listener-word-style
+H{
+ { font-name "sans-serif" }
+ { font-style bold }
+ { foreground $ text-color }
+} listener-word-style set-global
+
+M: input (print-input)
+ dup presented associate [
+ string>> listener-input-style get-global format
+ ] with-nesting nl ;
+
+M: word (print-input)
+ "Command: " listener-word-style get-global format . ;
+
+: print-input ( object interactor -- )
+ output>> [ (print-input) ] with-output-stream* ;
+
+: interactor-continue ( obj interactor -- )
+ [ mailbox>> mailbox-put ] [ scroll>bottom ] bi ;
+
+: interactor-finish ( interactor -- )
+ [ history>> history-add ] keep
+ [ print-input ]
+ [ clear-editor drop ]
+ [ model>> clear-undo drop ] 2tri ;
+
+: interactor-eof ( interactor -- )
+ dup interactor-busy? [
+ f over interactor-continue
+ ] unless drop ;
+
+: evaluate-input ( interactor -- )
+ dup interactor-busy? [ scroll>bottom ] [
+ [ control-value ] keep interactor-continue
+ ] if ;
+
+: 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 ?first ;
+
+: (call-listener) ( quot command listener -- )
+ input>> dup interactor-busy? [ 3drop ] [
+ [ print-input drop ]
+ [ nip interactor-continue ]
+ 3bi
+ ] if ;
+
+M:: interactor stream-read-unsafe ( n buf interactor -- count )
+ n [ 0 ] [
+ drop
+ interactor interactor-read dup [ join-lines ] when
+ n index-or-length [ head-slice 0 buf copy ] keep
+ ] if-zero ;
+
+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 stream-read-until
+ swap '[
+ _ interactor-read [
+ join-lines CHAR: \n suffix
+ [ _ member? ] dupd find
+ [ [ head ] when* ] dip dup not
+ ] [ f f f ] if*
+ ] [ drop ] produce swap [ concat "" prepend-as ] dip ;
+
+M: interactor dispose drop ;
+
+: go-to-error ( interactor error -- )
+ [ line>> 1 - ] [ column>> ] bi 2array
+ over set-caret
+ mark>caret ;
+
+TUPLE: listener-gadget < tool error-summary output scroller input ;
+
+listener-gadget default-font-size { 50 58 } n*v set-tool-dim
+
+: listener-streams ( listener -- input output )
+ [ input>> ] [ output>> <pane-stream> H{ } clone <style-stream> ] bi ;
+
+: init-input/output ( listener -- listener )
+ <interactor>
+ [ >>input ] [ pane new-pane t >>scrolls? >>output ] bi
+ dup listener-streams >>output drop ;
+
+: error-summary. ( -- )
+ error-counts keys [
+ H{ { table-gap { 3 3 } } } [
+ [ [ [ icon>> write-image ] with-cell ] each ] with-row
+ ] tabular-output
+ last-element off
+ { "Press " { $command tool "common" show-error-list } " to view errors." }
+ print-element
+ ] unless-empty ;
+
+: <error-summary> ( -- gadget )
+ error-list-model get [ drop error-summary. ] <pane-control>
+ error-summary-background <solid> >>interior ;
+
+: init-error-summary ( listener -- listener )
+ <error-summary> >>error-summary
+ dup error-summary>> f track-add ;
+
+: add-listener-area ( listener -- listener )
+ dup output>> margins <scroller> >>scroller
+ dup scroller>> white-interior 1 track-add ;
+
+: <listener-gadget> ( -- listener )
+ vertical listener-gadget new-track with-lines
+ add-toolbar
+ init-input/output
+ add-listener-area
+ init-error-summary ;
+
+M: listener-gadget focusable-child*
+ input>> dup popup>> or ;
+
+: wait-for-listener ( listener -- )
+ input>> flag>> 5 seconds wait-for-flag-timeout ;
+
+: listener-busy? ( listener -- ? )
+ input>> interactor-busy? ;
+
+: listener-window* ( -- listener )
+ <listener-gadget>
+ dup "Listener" open-status-window ;
+
+! : listener-window ( -- )
+! [ listener-window* drop ] with-ui ;
+
+! skov
+: listener-window ( -- ) environment-window ;
+
+\ listener-window H{ { +nullary+ t } } define-command
+
+: (get-listener) ( quot -- listener )
+ find-window [
+ [ raise-window ]
+ [
+ gadget-child
+ [ ]
+ [ input>> scroll>caret ]
+ [ input>> request-focus ] tri
+ ] bi
+ ] [ listener-window* ] if* ; inline
+
+: get-listener ( -- listener )
+ [ listener-gadget? ] (get-listener) ;
+
+! : show-listener ( -- )
+! get-listener drop ;
+
+! skov
+: show-listener ( -- ) [ border? ] find-window [ raise-window ] [ environment-window ] if* ;
+
+\ show-listener H{ { +nullary+ t } } define-command
+
+: get-ready-listener ( -- listener )
+ [
+ {
+ [ listener-gadget? ]
+ [ listener-busy? not ]
+ } 1&&
+ ] (get-listener) ;
+
+GENERIC: listener-input ( obj -- )
+
+M: input listener-input string>> listener-input ;
+
+M: string listener-input
+ get-listener input>>
+ [ set-editor-string ] [ request-focus ] bi ;
+
+: call-listener ( quot command -- )
+ get-ready-listener '[
+ _ _ _ dup wait-for-listener
+ [ (call-listener) ] with-ctrl-break
+ ] "Listener call" spawn drop ;
+
+M: listener-command invoke-command
+ [ command-quot ] [ nip ] 2bi call-listener ;
+
+M: listener-operation invoke-command
+ [ operation-quot ] [ nip command>> ] 2bi call-listener ;
+
+: eval-listener ( string -- )
+ get-listener input>> [ set-editor-string ] keep
+ evaluate-input ;
+
+: listener-run-files ( seq -- )
+ [
+ '[ _ [ run-file ] each ]
+ \ listener-run-files
+ call-listener
+ ] unless-empty ;
+
+: com-end ( listener -- )
+ input>> interactor-eof ;
+
+: clear-output ( listener -- )
+ output>> clear-pane ;
+
+\ clear-output H{ { +listener+ t } } define-command
+
+: clear-stack ( listener -- )
+ [ [ clear ] \ clear ] dip (call-listener) ;
+
+: use-if-necessary ( word manifest -- )
+ [ [ vocabulary>> ] keep ] dip pick over and [
+ manifest [
+ [ drop use-vocab ]
+ [ name>> 1array add-words-from ] 2bi
+ ] with-variable
+ ] [ 3drop ] if ;
+
+M: word accept-completion-hook
+ interactor>> manifest>> use-if-necessary ;
+
+M: object accept-completion-hook 2drop ;
+
+: quot-action ( interactor -- lines )
+ [ history>> history-add drop ] [ control-value ] [ select-all ] tri
+ parse-lines-interactive ;
+
+: do-recall? ( table error -- ? )
+ [ selection>> value>> not ] [ lexer-error? ] bi* and ;
+
+: recall-lexer-error ( interactor error -- )
+ over recall-previous go-to-error ;
+
+: make-restart-hook-quot ( error interactor -- quot )
+ over '[
+ dup hide-glass
+ _ do-recall? [ _ _ recall-lexer-error ] when
+ ] ;
+
+: frame-debugger ( debugger -- labeled )
+ "Error" debugger-color <framed-labeled-gadget> ;
+
+:: <debugger-popup> ( error continuation interactor -- popup )
+ error
+ continuation
+ error compute-restarts
+ error interactor make-restart-hook-quot
+ <debugger> frame-debugger ;
+
+: debugger-popup ( interactor error continuation -- )
+ pick <debugger-popup> one-line-elt swap show-listener-popup ;
+
+: try-parse ( lines -- quot/f )
+ [ parse-lines-interactive ] [ nip '[ _ rethrow ] ] recover ;
+
+M: interactor stream-read-quot
+ dup interactor-yield dup array? [
+ over interactor-finish try-parse
+ [ ] [ stream-read-quot ] ?if
+ ] [ nip ] if ;
+
+: interactor-operation ( gesture interactor -- ? )
+ [ token-model>> value>> ] keep word-at-caret
+ [ nip ] [ gesture>operation ] 2bi
+ [ invoke-command f ] [ drop t ] if* ;
+
+M: interactor handle-gesture
+ {
+ { [ over key-gesture? not ] [ call-next-method ] }
+ { [ dup popup>> ] [ ?check-popup { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
+ {
+ [ dup token-model>> value>> ]
+ [ { [ interactor-operation ] [ call-next-method ] } 2&& ]
+ }
+ [ call-next-method ]
+ } cond ;
+
+: delete-next-character/eof ( interactor -- )
+ dup model>> doc-string empty?
+ [ interactor-eof ] [ delete-next-character ] if ;
+
+interactor "interactor" f {
+ { T{ key-down f f "RET" } evaluate-input }
+ { T{ key-down f { C+ } "d" } delete-next-character/eof }
+ { T{ key-down f { C+ } "k" } clear-editor }
+} define-command-map
+
+interactor "completion" f {
+ { T{ key-down f f "TAB" } code-completion-popup }
+ { T{ key-down f { C+ } "p" } recall-previous }
+ { T{ key-down f { C+ } "n" } recall-next }
+ { T{ key-down f { C+ } "r" } history-completion-popup }
+ { T{ key-down f { C+ } "s" } history-completion-popup }
+} define-command-map
+
+: introduction. ( -- )
+ [
+ H{ { font-size $ default-font-size } } [
+ { $tip-of-the-day } print-element nl
+ { $strong "Press " { $snippet "F1" } " at any time for help." } print-element nl
+ version-info print-element
+ ] with-style
+ ] with-default-style nl nl ;
+
+: listener-thread ( listener -- )
+ dup input>> dup output>> [
+ [ com-browse ] help-hook set
+ '[ [ _ input>> ] 2dip debugger-popup ] error-hook set
+ error-summary? off
+ introduction.
+ listener
+ nl
+ "The listener has exited. To start it again, click “Restart Listener”." print
+ ] with-input-output+error-streams* ;
+
+: start-listener-thread ( listener -- )
+ '[
+ _
+ [ input>> register-self ]
+ [ listener-thread ]
+ bi
+ ] "Listener" spawn drop ;
+
+: restart-listener ( listener -- )
+ ! Returns when listener is ready to receive input.
+ {
+ [ com-end ]
+ [ clear-output ]
+ [ input>> clear-editor ]
+ [ start-listener-thread ]
+ [ wait-for-listener ]
+ } cleave ;
+
+: com-help ( -- ) "help.home" com-browse ;
+
+\ com-help H{ { +nullary+ t } } define-command
+
+: com-auto-use ( -- )
+ auto-use? toggle ;
+
+\ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
+
+: com-file-drop ( -- files )
+ dropped-files get-global ;
+
+\ com-file-drop H{ { +nullary+ t } { +listener+ t } } define-command
+
+listener-gadget "toolbar" f {
+ { f restart-listener }
+ { T{ key-down f ${ os macosx? M+ A+ ? } "u" } com-auto-use }
+ { T{ key-down f ${ os macosx? M+ A+ ? } "k" } clear-output }
+ { T{ key-down f ${ os macosx? M+ A+ ? } "K" } clear-stack }
+ { T{ key-down f f "F1" } com-help }
+} define-command-map
+
+listener-gadget "scrolling"
+"The listener's scroller can be scrolled from the keyboard."
+{
+ { T{ key-down f ${ os macosx? M+ A+ ? } "UP" } com-scroll-up }
+ { T{ key-down f ${ os macosx? M+ A+ ? } "DOWN" } com-scroll-down }
+ { T{ key-down f ${ os macosx? M+ A+ ? } "PAGE_UP" } com-page-up }
+ { T{ key-down f ${ os macosx? M+ A+ ? } "PAGE_DOWN" } com-page-down }
+} define-command-map
+
+listener-gadget "multi-touch" f {
+ { left-action recall-previous }
+ { right-action recall-next }
+ { up-action refresh-all }
+} define-command-map
+
+listener-gadget "touchbar" f {
+ { f refresh-all }
+ { f com-auto-use }
+ { f com-help }
+ { f show-error-list }
+} define-command-map
+
+listener-gadget "file-drop" "Files can be drag-and-dropped onto the listener."
+{
+ { T{ file-drop f f } com-file-drop }
+} define-command-map
+
+M: listener-gadget graft*
+ [ call-next-method ] [ restart-listener ] bi ;
+
+M: listener-gadget ungraft*
+ [ com-end ] [ call-next-method ] bi ;
+
+<PRIVATE
+
+:: make-font-style ( family size -- assoc )
+ H{ } clone
+ family font-name pick set-at
+ size font-size pick set-at ;
+
+PRIVATE>
+
+:: set-listener-font ( family size -- )
+ get-listener input>> :> interactor
+ interactor output>> :> output
+ interactor [
+ clone
+ family >>name
+ size >>size
+ ] change-font f >>line-height drop
+ family font-name output style>> set-at
+ size font-size output style>> set-at ;
+
+<PRIVATE
+
+:: adjust-listener-font-size ( listener delta -- )
+ listener input>> :> interactor
+ interactor output>> :> output
+ interactor
+ [ clone [ delta + ] change-size ] change-font
+ f >>line-height
+ font>> size>> font-size output style>> set-at ;
+
+PRIVATE>
+
+: com-font-size-plus ( listener -- )
+ 2 adjust-listener-font-size ;
+
+: com-font-size-minus ( listener -- )
+ -2 adjust-listener-font-size ;
+
+: com-font-size-normal ( listener -- )
+ default-font-size over input>> font>> size>> -
+ adjust-listener-font-size ;
+
+listener-gadget "fonts" f {
+ { T{ key-down f ${ os macosx? M+ C+ ? } "+" } com-font-size-plus }
+ { T{ key-down f ${ os macosx? M+ C+ ? } "=" } com-font-size-plus }
+ { T{ key-down f ${ os macosx? M+ C+ ? } "_" } com-font-size-minus }
+ { T{ key-down f ${ os macosx? M+ C+ ? } "-" } com-font-size-minus }
+ { T{ key-down f ${ os macosx? M+ C+ ? } "0" } com-font-size-normal }
+} define-command-map
+
+USE: lists.lazy
+USE: math.trig
+
+interactive-vocabs [ {
+ "io.encodings.utf8"
+ "io.encodings.binary"
+ "io.encodings.ascii"
+ "io.binary"
+ "io.directories"
+ "io.directories.hierarchy"
+ "lists.lazy"
+ "splitting"
+ "math.functions"
+ "math.trig"
+ "math.vectors"
+ "math.intervals"
+ "math.statistics"
+ "math.parser"
+ "sequences.deep"
+ "sequences.extras"
+ "sequences.generalizations"
+ "binary-search"
+ "vectors"
+ "quotations"
+ "byte-arrays"
+ "deques"
+ "regexp"
+ "calendar"
+ "classes"
+ "unicode.case"
+ "unicode.categories"
+ "io.files.info"
+ "colors"
+ "colors.hex"
+ "timers"
+ "sets"
+ "globs"
+ "scratchpad"
+} append ] change-global
--- /dev/null
+! Copyright (C) 2006, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.pathnames kernel literals memory namespaces sequences
+system tools.test ui ui.backend ui.commands ui.gestures
+ui.tools.browser ui.tools.button-list ui.tools.common
+ui.tools.error-list ui.tools.listener vocabs.refresh ui.tools.environment ;
+IN: ui.tools
+
+\ refresh-all H{ { +nullary+ t } { +listener+ t } } define-command
+\ refresh-and-test-all H{ { +nullary+ t } { +listener+ t } } define-command
+
+\ save H{ { +nullary+ t } } define-command
+
+: com-exit ( -- ) 0 exit ;
+
+\ com-exit H{ { +nullary+ t } } define-command
+
+tool "tool-switching" f {
+ { T{ key-down f ${ os macosx? M+ A+ ? } "l" } show-listener }
+ { T{ key-down f ${ os macosx? M+ A+ ? } "L" } listener-window }
+ { T{ key-down f ${ os macosx? M+ A+ ? } "b" } show-browser }
+ { T{ key-down f ${ os macosx? M+ A+ ? } "B" } browser-window }
+} define-command-map
+
+tool "common" f {
+ { T{ key-down f ${ os macosx? M+ A+ ? } "t" } show-active-buttons-popup }
+ { T{ key-down f ${ os macosx? M+ C+ ? } "w" } close-window }
+ { T{ key-down f ${ os macosx? M+ C+ ? } "q" } com-exit }
+ { T{ key-down f f "F2" } refresh-all }
+ { T{ key-down f { S+ } "F2" } refresh-and-test-all }
+ { T{ key-down f f "F3" } show-error-list }
+} os macosx? {
+ { T{ key-down f { C+ M+ } "f" } toggle-fullscreen }
+} {
+ { T{ key-down f { C+ } "F4" } close-window }
+ { T{ key-down f { A+ } "F4" } close-window }
+ { T{ key-down f f "F11" } toggle-fullscreen }
+} ? prepend define-command-map
+
+! : ui-tools-main ( -- )
+! f ui-stop-after-last-window? set-global
+! "resource:" absolute-path current-directory set-global
+! listener-window ;
+
+! skov
+: ui-tools-main ( -- )
+ f ui-stop-after-last-window? set-global
+ environment-window ;
+
+MAIN: ui-tools-main
--- /dev/null
+! Copyright (C) 2003, 2009 Slava Pestov, Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel kernel.private ;
+IN: math
+
+BUILTIN: fixnum ;
+BUILTIN: bignum ;
+BUILTIN: float ;
+
+PRIMITIVE: bits>double ( n -- x )
+PRIMITIVE: bits>float ( n -- x )
+PRIMITIVE: double>bits ( x -- n )
+PRIMITIVE: float>bits ( x -- n )
+
+<PRIVATE
+PRIMITIVE: bignum* ( x y -- z )
+PRIMITIVE: bignum+ ( x y -- z )
+PRIMITIVE: bignum- ( x y -- z )
+PRIMITIVE: bignum-bit? ( x n -- ? )
+PRIMITIVE: bignum-bitand ( x y -- z )
+PRIMITIVE: bignum-bitnot ( x -- y )
+PRIMITIVE: bignum-bitor ( x y -- z )
+PRIMITIVE: bignum-bitxor ( x y -- z )
+PRIMITIVE: bignum-gcd ( x y -- z )
+PRIMITIVE: bignum-log2 ( x -- n )
+PRIMITIVE: bignum-mod ( x y -- z )
+PRIMITIVE: bignum-shift ( x y -- z )
+PRIMITIVE: bignum/i ( x y -- z )
+PRIMITIVE: bignum/mod ( x y -- z w )
+PRIMITIVE: bignum< ( x y -- ? )
+PRIMITIVE: bignum<= ( x y -- ? )
+PRIMITIVE: bignum= ( x y -- ? )
+PRIMITIVE: bignum> ( x y -- ? )
+PRIMITIVE: bignum>= ( x y -- ? )
+PRIMITIVE: bignum>fixnum ( x -- y )
+PRIMITIVE: bignum>fixnum-strict ( x -- y )
+PRIMITIVE: both-fixnums? ( x y -- ? )
+PRIMITIVE: fixnum* ( x y -- z )
+PRIMITIVE: fixnum*fast ( x y -- z )
+PRIMITIVE: fixnum+ ( x y -- z )
+PRIMITIVE: fixnum+fast ( x y -- z )
+PRIMITIVE: fixnum- ( x y -- z )
+PRIMITIVE: fixnum-bitand ( x y -- z )
+PRIMITIVE: fixnum-bitnot ( x -- y )
+PRIMITIVE: fixnum-bitor ( x y -- z )
+PRIMITIVE: fixnum-bitxor ( x y -- z )
+PRIMITIVE: fixnum-fast ( x y -- z )
+PRIMITIVE: fixnum-mod ( x y -- z )
+PRIMITIVE: fixnum-shift ( x y -- z )
+PRIMITIVE: fixnum-shift-fast ( x y -- z )
+PRIMITIVE: fixnum/i ( x y -- z )
+PRIMITIVE: fixnum/i-fast ( x y -- z )
+PRIMITIVE: fixnum/mod ( x y -- z w )
+PRIMITIVE: fixnum/mod-fast ( x y -- z w )
+PRIMITIVE: fixnum< ( x y -- ? )
+PRIMITIVE: fixnum<= ( x y -- z )
+PRIMITIVE: fixnum> ( x y -- ? )
+PRIMITIVE: fixnum>= ( x y -- ? )
+PRIMITIVE: fixnum>bignum ( x -- y )
+PRIMITIVE: fixnum>float ( x -- y )
+PRIMITIVE: float* ( x y -- z )
+PRIMITIVE: float+ ( x y -- z )
+PRIMITIVE: float- ( x y -- z )
+PRIMITIVE: float-u< ( x y -- ? )
+PRIMITIVE: float-u<= ( x y -- ? )
+PRIMITIVE: float-u> ( x y -- ? )
+PRIMITIVE: float-u>= ( x y -- ? )
+PRIMITIVE: float/f ( x y -- z )
+PRIMITIVE: float< ( x y -- ? )
+PRIMITIVE: float<= ( x y -- ? )
+PRIMITIVE: float= ( x y -- ? )
+PRIMITIVE: float> ( x y -- ? )
+PRIMITIVE: float>= ( x y -- ? )
+PRIMITIVE: float>bignum ( x -- y )
+PRIMITIVE: float>fixnum ( x -- y )
+PRIVATE>
+
+GENERIC: >fixnum ( x -- n ) foldable
+GENERIC: >bignum ( x -- n ) foldable
+GENERIC: >integer ( x -- n ) foldable
+GENERIC: >float ( x -- y ) foldable
+GENERIC: integer>fixnum ( x -- y ) foldable
+GENERIC: integer>fixnum-strict ( x -- y ) foldable
+
+GENERIC: numerator ( a/b -- a )
+GENERIC: denominator ( a/b -- b )
+GENERIC: >fraction ( a/b -- a b )
+
+GENERIC: real-part ( z -- x )
+GENERIC: imaginary-part ( z -- y )
+
+MATH: number= ( x y -- ? ) foldable
+
+M: object number= 2drop f ;
+
+MATH: < ( x y -- ? ) foldable
+MATH: <= ( x y -- ? ) foldable
+MATH: > ( x y -- ? ) foldable
+MATH: >= ( x y -- ? ) foldable
+
+MATH: unordered? ( x y -- ? ) foldable
+MATH: u< ( x y -- ? ) foldable
+MATH: u<= ( x y -- ? ) foldable
+MATH: u> ( x y -- ? ) foldable
+MATH: u>= ( x y -- ? ) foldable
+
+M: object unordered? 2drop f ;
+
+MATH: + ( x y -- z ) foldable
+MATH: - ( x y -- z ) foldable
+MATH: * ( x y -- z ) foldable
+MATH: / ( x y -- z ) foldable
+MATH: /f ( x y -- z ) foldable
+MATH: /i ( x y -- z ) foldable
+MATH: mod ( x y -- z ) foldable
+
+MATH: /mod ( x y -- z w ) foldable
+
+MATH: bitand ( x y -- z ) foldable
+MATH: bitor ( x y -- z ) foldable
+MATH: bitxor ( x y -- z ) foldable
+GENERIC#: shift 1 ( x n -- y ) foldable
+GENERIC: bitnot ( x -- y ) foldable
+GENERIC#: bit? 1 ( x n -- ? ) foldable
+
+GENERIC: abs ( x -- y ) foldable
+
+<PRIVATE
+
+GENERIC: (log2) ( x -- n ) foldable
+
+PRIVATE>
+
+ERROR: log2-expects-positive x ;
+
+: log2 ( x -- n )
+ dup 0 <= [ log2-expects-positive ] [ (log2) ] if ; inline
+
+: zero? ( x -- ? ) 0 number= ; inline
+: 2/ ( x -- y ) -1 shift ; inline
+: sq ( x -- y ) dup * ; inline
+: neg ( x -- -x ) -1 * ; inline
+: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
+: ?1+ ( x -- y ) [ 1 + ] [ 0 ] if* ; inline
+: rem ( x y -- z ) abs [ mod ] [ + ] [ mod ] tri ; foldable
+: 2^ ( n -- 2^n ) 1 swap shift ; inline
+: even? ( n -- ? ) 1 bitand zero? ; inline
+: odd? ( n -- ? ) 1 bitand 1 number= ; inline
+
+GENERIC: neg? ( x -- ? )
+
+: if-zero ( ..a n quot1: ( ..a -- ..b ) quot2: ( ..a n -- ..b ) -- ..b )
+ [ dup zero? ] [ [ drop ] prepose ] [ ] tri* if ; inline
+
+: when-zero ( ... n quot: ( ... -- ... x ) -- ... x ) [ ] if-zero ; inline
+
+: unless-zero ( ... n quot: ( ... n -- ... ) -- ... ) [ ] swap if-zero ; inline
+
+: until-zero ( ... n quot: ( ... x -- ... y ) -- ... ) [ dup zero? ] swap until drop ; inline
+
+UNION: integer fixnum bignum ;
+
+TUPLE: ratio
+ { numerator integer read-only }
+ { denominator integer read-only } ;
+
+UNION: rational integer ratio ;
+
+M: rational neg? 0 < ; inline
+
+UNION: real rational float ;
+
+TUPLE: complex
+ { real real read-only }
+ { imaginary real read-only } ;
+
+UNION: number real complex ;
+
+GENERIC: recip ( x -- y )
+
+M: number recip 1 swap / ; inline
+
+: rect> ( x y -- z )
+ ! Note: an imaginary 0.0 should still create a complex
+ dup 0 = [ drop ] [ complex boa ] if ; inline
+
+GENERIC: >rect ( z -- x y )
+
+M: real >rect 0 ; inline
+
+M: complex >rect [ real-part ] [ imaginary-part ] bi ; inline
+
+<PRIVATE
+
+: (gcd) ( b a x y -- a d )
+ swap [
+ nip
+ ] [
+ [ /mod [ over * swapd - ] dip ] keep (gcd)
+ ] if-zero ; inline recursive
+
+PRIVATE>
+
+: gcd ( x y -- a d )
+ [ 0 1 ] 2dip (gcd) dup 0 < [ neg ] when ; inline
+
+MATH: simple-gcd ( x y -- d ) foldable
+
+<PRIVATE
+
+: fixnum-gcd ( x y -- d ) { fixnum fixnum } declare gcd nip ;
+
+PRIVATE>
+
+M: fixnum simple-gcd fixnum-gcd ; inline
+
+M: bignum simple-gcd bignum-gcd ; inline
+
+: fp-bitwise= ( x y -- ? ) [ double>bits ] same? ; inline
+
+GENERIC: fp-special? ( x -- ? )
+GENERIC: fp-nan? ( x -- ? )
+GENERIC: fp-qnan? ( x -- ? )
+GENERIC: fp-snan? ( x -- ? )
+GENERIC: fp-infinity? ( x -- ? )
+GENERIC: fp-nan-payload ( x -- bits )
+GENERIC: fp-sign ( x -- ? )
+
+M: object fp-special? drop f ; inline
+M: object fp-nan? drop f ; inline
+M: object fp-qnan? drop f ; inline
+M: object fp-snan? drop f ; inline
+M: object fp-infinity? drop f ; inline
+
+: <fp-nan> ( payload -- nan )
+ 0x7ff0000000000000 bitor bits>double ; inline
+
+GENERIC: next-float ( m -- n )
+GENERIC: prev-float ( m -- n )
+
+: next-power-of-2 ( m -- n )
+ dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline
+
+: power-of-2? ( n -- ? )
+ dup 0 <= [ drop f ] [ dup 1 - bitand zero? ] if ; foldable
+
+: align ( m w -- n )
+ 1 - [ + ] keep bitnot bitand ; inline
+
+: each-integer-from ( ... i n quot: ( ... i -- ... ) -- ... )
+ 2over < [
+ [ nip call ] 3keep
+ [ 1 + ] 2dip each-integer-from
+ ] [
+ 3drop
+ ] if ; inline recursive
+
+: each-integer ( ... n quot: ( ... i -- ... ) -- ... )
+ [ 0 ] 2dip each-integer-from ; inline
+
+: times ( ... n quot: ( ... -- ... ) -- ... )
+ [ drop ] prepose each-integer ; inline
+
+: find-integer-from ( ... i n quot: ( ... i -- ... ? ) -- ... i/f )
+ 2over < [
+ [ nip call ] 3keep roll
+ [ 2drop ]
+ [ [ 1 + ] 2dip find-integer-from ] if
+ ] [
+ 3drop f
+ ] if ; inline recursive
+
+: find-integer ( ... n quot: ( ... i -- ... ? ) -- ... i/f )
+ [ 0 ] 2dip find-integer-from ; inline
+
+: find-last-integer ( ... n quot: ( ... i -- ... ? ) -- ... i/f )
+ over 0 < [
+ 2drop f
+ ] [
+ [ call ] 2keep rot [
+ drop
+ ] [
+ [ 1 - ] dip find-last-integer
+ ] if
+ ] if ; inline recursive
+
+: all-integers-from? ( ... i n quot: ( ... i -- ... ? ) -- ... ? )
+ 2over < [
+ [ nip call ] 3keep roll
+ [ [ 1 + ] 2dip all-integers-from? ]
+ [ 3drop f ] if
+ ] [
+ 3drop t
+ ] if ; inline recursive
+
+: all-integers? ( ... n quot: ( ... i -- ... ? ) -- ... ? )
+ [ 0 ] 2dip all-integers-from? ; inline
+
+: half ( x -- x/2 ) 2 / ;
+
+: special-times ( initial n quot -- final ) times ; inline
--- /dev/null
+! Copyright (C) 2005, 2011 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien arrays assocs byte-arrays classes
+classes.algebra classes.algebra.private classes.maybe
+combinators generic generic.standard hashtables kernel
+kernel.private math quotations sequences sequences.private
+strings words ;
+IN: slots
+
+<PRIVATE
+PRIMITIVE: set-slot ( value obj n -- )
+PRIMITIVE: slot ( obj m -- value )
+PRIVATE>
+
+TUPLE: slot-spec name offset class initial read-only ;
+
+PREDICATE: reader < word "reader" word-prop ;
+
+PREDICATE: reader-method < method "reading" word-prop >boolean ;
+
+PREDICATE: writer < word "writer" word-prop ;
+
+PREDICATE: writer-method < method "writing" word-prop >boolean ;
+
+: <slot-spec> ( -- slot-spec )
+ slot-spec new
+ object bootstrap-word >>class ;
+
+: define-typecheck ( class generic quot props -- )
+ [ create-method ] 2dip
+ [ [ props>> ] [ drop ] [ ] tri* assoc-union! drop ]
+ [ drop define ]
+ [ 2drop make-inline ]
+ 3tri ;
+
+GENERIC#: reader-quot 1 ( class slot-spec -- quot )
+
+M: object reader-quot
+ nip [ offset>> [ slot ] curry ] [ class>> ] bi
+ dup object bootstrap-word eq?
+ [ drop ] [ 1array [ declare ] curry compose ] if ;
+
+! : reader-word ( name -- word )
+! ">>" append "accessors" create-word
+! dup t "reader" set-word-prop ;
+
+! skov
+: reader-word ( name -- word )
+ [ ">>" append "accessors" create-word ]
+ [ " (accessor)" append >>name ] bi
+ dup t "reader" set-word-prop ;
+
+: reader-props ( slot-spec -- assoc )
+ "reading" associate ;
+
+: define-reader-generic ( name -- )
+ reader-word ( object -- value ) define-simple-generic ;
+
+: define-reader ( class slot-spec -- )
+ [ nip name>> define-reader-generic ]
+ [
+ {
+ [ drop ]
+ [ nip name>> reader-word ]
+ [ reader-quot ]
+ [ nip reader-props ]
+ } 2cleave define-typecheck
+ ] 2bi ;
+
+! : writer-word ( name -- word )
+! "<<" append "accessors" create-word
+! dup t "writer" set-word-prop ;
+
+! skov
+: writer-word ( name -- word )
+ [ "<<" append "accessors" create-word ]
+ [ " (writer)" append >>name ] bi
+ dup t "writer" set-word-prop ;
+
+ERROR: bad-slot-value value class ;
+
+GENERIC: instance-check-quot ( obj -- quot )
+
+M: class instance-check-quot
+ {
+ { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
+ { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
+ [ call-next-method ]
+ } cond ;
+
+M: object instance-check-quot
+ [ predicate-def [ dup ] prepose ] keep
+ [ bad-slot-value ] curry [ unless ] curry compose ;
+
+GENERIC#: writer-quot 1 ( class slot-spec -- quot )
+
+M: object writer-quot
+ nip
+ [ class>> instance-check-quot dup empty? [ [ dip ] curry ] unless ]
+ [ offset>> [ set-slot ] curry ]
+ bi append ;
+
+: writer-props ( slot-spec -- assoc )
+ "writing" associate ;
+
+: define-writer-generic ( name -- )
+ writer-word ( value object -- ) define-simple-generic ;
+
+: define-writer ( class slot-spec -- )
+ [ nip name>> define-writer-generic ] [
+ {
+ [ drop ]
+ [ nip name>> writer-word ]
+ [ writer-quot ]
+ [ nip writer-props ]
+ } 2cleave define-typecheck
+ ] 2bi ;
+
+! : setter-word ( name -- word )
+! ">>" prepend "accessors" create-word ;
+
+! skov
+: setter-word ( name -- word )
+ [ ">>" prepend "accessors" create-word ]
+ [ " (mutator)" append >>name ] bi ;
+
+: define-setter ( name -- )
+ dup setter-word dup deferred? [
+ swap writer-word 1quotation [ over ] prepose
+ ( object value -- object ) define-inline
+ ] [ 2drop ] if ;
+
+! : changer-word ( name -- word )
+! "change-" prepend "accessors" create-word ;
+
+! skov
+: changer-word ( name -- word )
+ [ "change-" prepend "accessors" create-word ]
+ [ "change " prepend >>name ] bi ;
+
+: define-changer ( name -- )
+ dup changer-word dup deferred? [
+ over reader-word 1quotation
+ [ dip call ] curry [ dip swap ] curry [ over ] prepose
+ rot setter-word 1quotation compose
+ ( object quot -- object ) define-inline
+ ] [ 2drop ] if ;
+
+: define-slot-methods ( class slot-spec -- )
+ [ define-reader ]
+ [
+ dup read-only>> [ 2drop ] [
+ [ name>> define-setter drop ]
+ [ name>> define-changer drop ]
+ [ define-writer ]
+ 2tri
+ ] if
+ ] 2bi ;
+
+: define-accessors ( class specs -- )
+ [ define-slot-methods ] with each ;
+
+: define-protocol-slot ( name -- )
+ {
+ [ define-reader-generic ]
+ [ define-writer-generic ]
+ [ define-setter ]
+ [ define-changer ]
+ } cleave ;
+
+DEFER: initial-value
+
+GENERIC: initial-value* ( class -- object ? )
+
+M: class initial-value* drop f f ;
+
+M: maybe initial-value* drop f t ;
+
+! Default initial value is f, 0, or the default initial value of
+! the smallest class. Special case 0 because float is ostensibly
+! smaller than integer in union{ integer float } because of
+! alphabetical sorting.
+M: anonymous-union initial-value*
+ {
+ { [ f over instance? ] [ drop f t ] }
+ { [ 0 over instance? ] [ drop 0 t ] }
+ [
+ members>> sort-classes [ initial-value ] { } map>assoc
+ ?last [ second t ] [ f f ] if*
+ ]
+ } cond ;
+
+! See if any of the initial values fit the intersection class,
+! or else return that none do, and leave it up to the user to
+! provide an initial: value.
+M: anonymous-intersection initial-value*
+ {
+ { [ f over instance? ] [ drop f t ] }
+ { [ 0 over instance? ] [ drop 0 t ] }
+ [
+ [ ]
+ [ participants>> sort-classes [ initial-value ] { } map>assoc ]
+ [ ] tri
+
+ [ [ first2 nip ] dip instance? ] curry find swap [
+ nip second t
+ ] [
+ 2drop f f
+ ] if
+ ]
+ } cond ;
+
+: initial-value ( class -- object ? )
+ {
+ { [ dup only-classoid? ] [ dup initial-value* ] }
+ { [ dup "initial-value" word-prop ] [ dup "initial-value" word-prop t ] }
+ { [ \ f bootstrap-word over class<= ] [ f t ] }
+ { [ \ array-capacity bootstrap-word over class<= ] [ 0 t ] }
+ { [ \ integer-array-capacity bootstrap-word over class<= ] [ 0 t ] }
+ { [ bignum bootstrap-word over class<= ] [ 0 >bignum t ] }
+ { [ float bootstrap-word over class<= ] [ 0.0 t ] }
+ { [ string bootstrap-word over class<= ] [ "" t ] }
+ { [ array bootstrap-word over class<= ] [ { } t ] }
+ { [ byte-array bootstrap-word over class<= ] [ B{ } t ] }
+ { [ pinned-alien bootstrap-word over class<= ] [ <bad-alien> t ] }
+ { [ quotation bootstrap-word over class<= ] [ [ ] t ] }
+ [ dup initial-value* ]
+ } cond nipd ;
+
+GENERIC: make-slot ( desc -- slot-spec )
+
+M: string make-slot
+ <slot-spec>
+ swap >>name ;
+
+: peel-off-name ( slot-spec array -- slot-spec array )
+ [ first >>name ] [ rest ] bi ; inline
+
+: init-slot-class ( slot-spec class -- slot-spec )
+ [ >>class ] [ initial-value [ >>initial ] [ drop ] if ] bi ;
+
+: peel-off-class ( slot-spec array -- slot-spec array )
+ dup empty? [
+ dup first classoid? [
+ [ first init-slot-class ] [ rest ] bi
+ ] when
+ ] unless ;
+
+ERROR: bad-slot-attribute key ;
+
+: peel-off-attributes ( slot-spec array -- slot-spec array )
+ dup empty? [
+ unclip {
+ { initial: [ [ first >>initial ] [ rest ] bi ] }
+ { read-only [ [ t >>read-only ] dip ] }
+ [ bad-slot-attribute ]
+ } case
+ ] unless ;
+
+ERROR: bad-initial-value name initial-value class ;
+
+: check-initial-value ( slot-spec -- slot-spec )
+ [ ] [
+ [ ] [ initial>> ] [ class>> ] tri
+ 2dup instance? [
+ 2drop
+ ] [
+ [ name>> ] 2dip bad-initial-value
+ ] if
+ ] if-bootstrapping ;
+
+M: array make-slot
+ <slot-spec>
+ swap
+ peel-off-name
+ peel-off-class
+ [ dup empty? ] [ peel-off-attributes ] until drop
+ check-initial-value ;
+
+M: slot-spec make-slot
+ check-initial-value ;
+
+: make-slots ( slots -- specs )
+ [ make-slot ] map ;
+
+: finalize-slots ( specs base -- specs )
+ over length <iota> [ + ] with map [ >>offset ] 2map ;
+
+: slot-named* ( name specs -- offset spec/f )
+ [ name>> = ] with find ;
+
+: slot-named ( name specs -- spec/f )
+ slot-named* nip ;
+
--- /dev/null
+! Copyright (C) 2004, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays byte-vectors classes
+classes.algebra.private classes.builtin classes.error
+classes.intersection classes.maybe classes.mixin classes.parser
+classes.predicate classes.singleton classes.tuple
+classes.tuple.parser classes.union combinators compiler.units
+definitions effects effects.parser fry generic generic.hook
+generic.math generic.parser generic.standard hash-sets
+hashtables hashtables.identity init io.pathnames kernel lexer
+locals.errors locals.parser macros math memoize namespaces
+parser quotations sbufs sequences slots source-files splitting
+strings strings.parser strings.parser.private vectors
+vocabs.loader vocabs.parser words words.alias words.constant
+words.symbol ;
+IN: bootstrap.syntax
+
+! These words are defined as a top-level form, instead of with
+! defining parsing words, because during stage1 bootstrap, the
+! "syntax" vocabulary is copied from the host. When stage1
+! bootstrap completes, the host's syntax vocabulary is deleted
+! from the target, then this top-level form creates the
+! target's "syntax" vocabulary as one of the first things done
+! in stage2.
+
+: define-delimiter ( name -- )
+ "syntax" lookup-word t "delimiter" set-word-prop ;
+
+: define-core-syntax ( name quot -- )
+ [ dup "syntax" lookup-word [ ] [ no-word-error ] ?if ] dip
+ define-syntax ;
+
+: false ( -- false ) f ;
+: true ( -- true ) t ;
+
+[
+ { "]" "}" ";" ">>" } [ define-delimiter ] each
+
+ "PRIMITIVE:" [
+ current-vocab name>>
+ scan-word scan-effect ensure-primitive
+ ] define-core-syntax
+
+ "CS{" [
+ "Call stack literals are not supported" throw
+ ] define-core-syntax
+
+ "IN:" [ scan-token set-current-vocab ] define-core-syntax
+
+ "<PRIVATE" [ begin-private ] define-core-syntax
+
+ "PRIVATE>" [ end-private ] define-core-syntax
+
+ "REUSE:" [ scan-token reload ] define-core-syntax
+
+ "USE:" [ scan-token use-vocab ] define-core-syntax
+
+ "UNUSE:" [ scan-token unuse-vocab ] define-core-syntax
+
+ "USING:" [ ";" [ use-vocab ] each-token ] define-core-syntax
+
+ "QUALIFIED:" [ scan-token dup add-qualified ] define-core-syntax
+
+ "QUALIFIED-WITH:" [ scan-token scan-token add-qualified ] define-core-syntax
+
+ "FROM:" [
+ scan-token "=>" expect ";" parse-tokens add-words-from
+ ] define-core-syntax
+
+ "EXCLUDE:" [
+ scan-token "=>" expect ";" parse-tokens add-words-excluding
+ ] define-core-syntax
+
+ "RENAME:" [
+ scan-token scan-token "=>" expect scan-token add-renamed-word
+ ] define-core-syntax
+
+ "NAN:" [ 16 scan-base <fp-nan> suffix! ] define-core-syntax
+
+ "f" [ f suffix! ] define-core-syntax
+
+ "CHAR:" [
+ lexer get parse-raw [ "token" throw-unexpected-eof ] unless* {
+ { [ dup length 1 = ] [ first ] }
+ { [ "\\" ?head ] [ next-escape >string "" assert= ] }
+ [ name>char-hook get call( name -- char ) ]
+ } cond suffix!
+ ] define-core-syntax
+
+ "\"" [ parse-string suffix! ] define-core-syntax
+
+ "SBUF\"" [
+ lexer get skip-blank parse-string >sbuf suffix!
+ ] define-core-syntax
+
+ "P\"" [
+ lexer get skip-blank parse-string <pathname> suffix!
+ ] define-core-syntax
+
+ "[" [ parse-quotation suffix! ] define-core-syntax
+ "{" [ \ } [ >array ] parse-literal ] define-core-syntax
+ "V{" [ \ } [ >vector ] parse-literal ] define-core-syntax
+ "B{" [ \ } [ >byte-array ] parse-literal ] define-core-syntax
+ "BV{" [ \ } [ >byte-vector ] parse-literal ] define-core-syntax
+ "H{" [ \ } [ parse-hashtable ] parse-literal ] define-core-syntax
+ "IH{" [ \ } [ >identity-hashtable ] parse-literal ] define-core-syntax
+ "T{" [ parse-tuple-literal suffix! ] define-core-syntax
+ "W{" [ \ } [ first <wrapper> ] parse-literal ] define-core-syntax
+ "HS{" [ \ } [ >hash-set ] parse-literal ] define-core-syntax
+
+ "POSTPONE:" [ scan-word suffix! ] define-core-syntax
+ "\\" [ scan-word <wrapper> suffix! ] define-core-syntax
+ "M\\" [ scan-word scan-word lookup-method <wrapper> suffix! ] define-core-syntax
+ "auto-use" [ t auto-use? set-global ] define-core-syntax
+ "delimiter" [ last-word t "delimiter" set-word-prop ] define-core-syntax
+ "deprecated" [ last-word make-deprecated ] define-core-syntax
+ "flushable" [ last-word make-flushable ] define-core-syntax
+ "foldable" [ last-word make-foldable ] define-core-syntax
+ "inline" [ last-word make-inline ] define-core-syntax
+ "recursive" [ last-word make-recursive ] define-core-syntax
+
+ "SYNTAX:" [
+ scan-new-word parse-definition define-syntax
+ ] define-core-syntax
+
+ "BUILTIN:" [
+ scan-word-name
+ current-vocab lookup-word
+ (parse-tuple-definition)
+ 2drop builtin-class check-instance drop
+ ] define-core-syntax
+
+ "SYMBOL:" [
+ scan-new-word define-symbol
+ ] define-core-syntax
+
+ "SYMBOLS:" [
+ ";" [ create-word-in [ reset-generic ] [ define-symbol ] bi ] each-token
+ ] define-core-syntax
+
+ "INITIALIZE:" [
+ scan-word parse-definition [ initialize ] 2curry append!
+ ] define-core-syntax
+
+ "SINGLETONS:" [
+ ";" [ create-class-in define-singleton-class ] each-token
+ ] define-core-syntax
+
+ "DEFER:" [
+ scan-token current-vocab create-word
+ [ fake-definition ] [ set-last-word ] [ undefined-def define ] tri
+ ] define-core-syntax
+
+ "ALIAS:" [
+ scan-new-word scan-word define-alias
+ ] define-core-syntax
+
+ "CONSTANT:" [
+ scan-new-word scan-object define-constant
+ ] define-core-syntax
+
+ ":" [
+ (:) define-declared
+ ] define-core-syntax
+
+ "GENERIC:" [
+ [ simple-combination ] (GENERIC:)
+ ] define-core-syntax
+
+ "GENERIC#:" [
+ [ scan-number <standard-combination> ] (GENERIC:)
+ ] define-core-syntax
+
+ "MATH:" [
+ [ math-combination ] (GENERIC:)
+ ] define-core-syntax
+
+ "HOOK:" [
+ [ scan-word <hook-combination> ] (GENERIC:)
+ ] define-core-syntax
+
+ "M:" [
+ (M:) define
+ ] define-core-syntax
+
+ "UNION:" [
+ scan-new-class parse-array-def define-union-class
+ ] define-core-syntax
+
+ "INTERSECTION:" [
+ scan-new-class parse-array-def define-intersection-class
+ ] define-core-syntax
+
+ "MIXIN:" [
+ scan-new-class define-mixin-class
+ ] define-core-syntax
+
+ "INSTANCE:" [
+ location [
+ scan-word scan-word 2dup add-mixin-instance
+ <mixin-instance>
+ ] dip remember-definition
+ ] define-core-syntax
+
+ "PREDICATE:" [
+ scan-new-class
+ "<" expect
+ scan-class
+ parse-definition define-predicate-class
+ ] define-core-syntax
+
+ "SINGLETON:" [
+ scan-new-class define-singleton-class
+ ] define-core-syntax
+
+ "TUPLE:" [
+ parse-tuple-definition define-tuple-class
+ ] define-core-syntax
+
+ "final" [
+ last-word make-final
+ ] define-core-syntax
+
+ "SLOT:" [
+ scan-token define-protocol-slot
+ ] define-core-syntax
+
+ "C:" [
+ scan-new-word scan-word define-boa-word
+ ] define-core-syntax
+
+ "ERROR:" [
+ parse-tuple-definition
+ pick save-location
+ define-error-class
+ ] define-core-syntax
+
+ "FORGET:" [
+ scan-object forget
+ ] define-core-syntax
+
+ "(" [
+ ")" parse-effect suffix!
+ ] define-core-syntax
+
+ "MAIN:" [
+ scan-word dup \ [ = [
+ drop "( main )" <uninterned-word> dup
+ parse-quotation ( -- ) define-declared
+ ] when dup ( -- ) check-stack-effect
+ [ current-vocab main<< ]
+ [ current-source-file get [ main<< ] [ drop ] if* ] bi
+ ] define-core-syntax
+
+ "<<" [
+ [
+ \ >> parse-until >quotation
+ ] with-nested-compilation-unit call( -- )
+ ] define-core-syntax
+
+ "call-next-method" [
+ current-method get [
+ literalize suffix!
+ \ (call-next-method) suffix!
+ ] [
+ not-in-a-method-error
+ ] if*
+ ] define-core-syntax
+
+ "maybe{" [
+ \ } [ <anonymous-union> <maybe> ] parse-literal
+ ] define-core-syntax
+
+ "not{" [
+ \ } [ <anonymous-union> <anonymous-complement> ] parse-literal
+ ] define-core-syntax
+
+ "intersection{" [
+ \ } [ <anonymous-intersection> ] parse-literal
+ ] define-core-syntax
+
+ "union{" [
+ \ } [ <anonymous-union> ] parse-literal
+ ] define-core-syntax
+
+ "initial:" "syntax" lookup-word define-symbol
+
+ "read-only" "syntax" lookup-word define-symbol
+
+ "call(" [ \ call-effect parse-call-paren ] define-core-syntax
+
+ "execute(" [ \ execute-effect parse-call-paren ] define-core-syntax
+
+ "<<<<<<<" [ version-control-merge-conflict ] define-core-syntax
+ "=======" [ version-control-merge-conflict ] define-core-syntax
+ ">>>>>>>" [ version-control-merge-conflict ] define-core-syntax
+
+ "<<<<<<" [ version-control-merge-conflict ] define-core-syntax
+ "======" [ version-control-merge-conflict ] define-core-syntax
+ ">>>>>>" [ version-control-merge-conflict ] define-core-syntax
+
+ "'[" [
+ t in-fry? [ parse-quotation ] with-variable fry append!
+ ] define-core-syntax
+
+ "'{" [
+ t in-fry? [ \ } parse-until >array ] with-variable fry append!
+ ] define-core-syntax
+
+ "'HS{" [
+ t in-fry? [ \ } parse-until >array ] with-variable fry
+ [ >hash-set ] compose append!
+ ] define-core-syntax
+
+ "'H{" [
+ t in-fry? [ \ } parse-until >array ] with-variable fry
+ [ parse-hashtable ] compose append!
+ ] define-core-syntax
+
+ "_" [
+ in-fry? get [ \ _ suffix! ] [ not-in-a-fry ] if
+ ] define-core-syntax
+
+ "@" [
+ in-fry? get [ \ @ suffix! ] [ not-in-a-fry ] if
+ ] define-core-syntax
+
+ "MACRO:" [ (:) define-macro ] define-core-syntax
+
+ "MEMO:" [ (:) define-memoized ] define-core-syntax
+ "IDENTITY-MEMO:" [ (:) define-identity-memoized ] define-core-syntax
+
+ ":>" [
+ in-lambda? get [ :>-outside-lambda-error ] unless
+ scan-token parse-def suffix!
+ ] define-core-syntax
+ "[|" [ parse-lambda append! ] define-core-syntax
+ "[let" [ parse-let append! ] define-core-syntax
+
+ "::" [ (::) define-declared ] define-core-syntax
+ "M::" [ (M::) define ] define-core-syntax
+ "MACRO::" [ (::) define-macro ] define-core-syntax
+ "MEMO::" [ (::) define-memoized ] define-core-syntax
+ "IDENTITY-MEMO::" [ (::) define-identity-memoized ] define-core-syntax
+
+ "STARTUP-HOOK:" [
+ scan-word
+ dup \ [ = [ drop parse-quotation ] [ 1quotation ] if
+ current-vocab name>> [ add-startup-hook ] 2curry append!
+ ] define-core-syntax
+
+ "SHUTDOWN-HOOK:" [
+ scan-word
+ dup \ [ = [ drop parse-quotation ] [ 1quotation ] if
+ current-vocab name>> [ add-shutdown-hook ] 2curry append!
+ ] define-core-syntax
+] with-compilation-unit
--- /dev/null
+! File: skov
+! Version: 0.1
+! DRI: Dave Carlton
+! Description: Code for skov
+! Copyright (C) 2016 Nicolas Pénet.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.smart help.topics
+kernel locals models ui.gadgets
+ui.gadgets.packs vocabs words
+skov.basis.code.execution
+skov.basis.ui.tools.environment ;
+IN: ui.gadgets.buttons.activate
+
+: vocab/word? ( obj -- ? )
+ [ vocab? ] [ [ link? ] [ name>> word? ] [ drop f ] smart-if ] bi or ;
+
+: vocab-name ( obj -- str )
+ name>> [ word? ] [ vocabulary>> ] smart-when ;
+
+:: <activate-button> ( model -- gadget )
+ model value>> vocab-name :> name
+ name interactive?
+ [ blue-background "Active"
+ [ drop name remove-interactive-vocab model notify-connections ]
+ <round-button> "Deactivate this vocabulary" >>tooltip ]
+ [ dark-background "Inactive"
+ [ drop name add-interactive-vocab model notify-connections ]
+ <round-button> "Activate this vocabulary" >>tooltip ] if ;
+
+TUPLE: active/inactive < pack ;
+
+: <active/inactive> ( model -- gadget )
+ active/inactive new swap >>model ;
+
+M: active/inactive model-changed
+ dup clear-gadget swap
+ [ value>> vocab/word? ] [ <activate-button> add-gadget ] smart-when* drop ;
+
+IN: ui.gadgets.buttons.round
+
+TUPLE: round-button < button ;
+
+M: round-button pref-dim*
+ gadget-child [ text>> length 1 > ]
+ [ pref-dim first2 [ 15 + ] dip [ 20 max ] bi@ 2array ]
+ [ { 20 20 } ] smart-if* ;
+
+:: <round-button> ( colors label quot -- button )
+ label quot round-button new-button
+ colors dup first >gray gray>> 0.5 < light-text-colour dark-text-colour ?
+ <gradient-squircle> >>interior
+ dup gadget-child
+ [ t >>bold? 13 >>size transparent >>background ] change-font drop ;
+
+IN: ui.pens.gradient-rounded
+
+TUPLE: gradient-shape < caching-pen colors foreground shape last-vertices last-colors ;
+TUPLE: gradient-squircle < gradient-shape ;
+TUPLE: gradient-arrow < gradient-shape ;
+TUPLE: gradient-pointy < gradient-shape ;
+TUPLE: gradient-dynamic-shape < gradient-shape selected? ;
+
+: <gradient-squircle> ( colors foreground -- gradient )
+ gradient-squircle new swap >>foreground swap >>colors ;
+
+: <gradient-arrow> ( colors foreground -- gradient )
+ gradient-arrow new swap >>foreground swap >>colors ;
+
+: <gradient-pointy> ( colors foreground -- gradient )
+ gradient-pointy new swap >>foreground swap >>colors ;
+
+: <gradient-dynamic-shape> ( colors foreground selected? -- gradient )
+ gradient-dynamic-shape new swap >>selected? swap >>foreground swap >>colors ;
+
+<PRIVATE
+
+CONSTANT: tau 6.283185307179586
+CONSTANT: points 100
+
+: squircle-point ( theta -- xy )
+ [ cos ] [ sin ] bi [ [ abs sqrt ] [ sgn ] bi * 0.5 * 0.5 + ] bi@ 2array ;
+
+:: tan-point ( y slope -- xy )
+ y tau * 4 / tan 300 / 0.5 min y slope / + y 2array ;
+
+:: squircle ( -- seq )
+ 1/4 tau * 3/4 tau * 1/2 tau * points / <range> [ squircle-point ] map ;
+
+:: arrow ( -- seq )
+ { { -0.25 1 } { 0 0.5 } { -0.25 0 } } ;
+
+:: wide-narrow ( slope -- seq )
+ 0.0 1.0 1 points / <range> [ slope tan-point ] map reverse ;
+
+: narrow-wide ( slope -- seq )
+ wide-narrow unzip [ reverse ] dip zip ;
+
+:: wide-narrow-wide ( slope -- seq )
+ slope wide-narrow unzip drop slope narrow-wide unzip [ [ min ] 2map ] dip zip ;
+
+:: narrow-wide-narrow ( slope -- seq )
+ slope wide-narrow unzip drop slope narrow-wide unzip [ [ max ] 2map ] dip zip ;
+
+:: vertices ( dim left-shape right-shape symmetric? -- seq )
+ dim first2 :> ( x y )
+ left-shape right-shape [ call( -- seq ) [ y v*n ] map ] bi@
+ reverse symmetric? [ [ first2 [ neg ] dip 2array ] map ] unless
+ [ first2 swap x swap - swap 2array ] map append
+ x 2 / y 2 / 2array prefix dup second suffix ;
+
+:: interp-color ( x colors -- seq )
+ colors [ >rgba-components 4array ] map first2 zip [ first2 dupd - x * - ] map ;
+
+:: vertices-colors ( dim seq colors -- seq )
+ seq [ second dim second / colors interp-color ] map ;
+
+: draw-triangle-fan ( vertices colors -- )
+ GL_TRIANGLE_FAN glBegin
+ [ first3 glColor3f first2 glVertex2f ] 2each
+ glEnd ;
+
+:: gradient-start ( edge center -- s )
+ center first2 :> ( xc yc )
+ edge first2 :> ( xe ye )
+ 8 xe xc - sq ye yc - sq + sqrt / :> alpha
+ xe xe xc - alpha * -
+ ye ye yc - alpha * - 8 max 16 min 2array ;
+
+: draw-triangle-fan-selected ( vertices -- )
+ unclip dupd [ gradient-start ] curry map
+ GL_TRIANGLE_STRIP glBegin
+ [ 1.0 1.0 1.0 0.0 glColor4f first2 glVertex2f
+ 1.0 1.0 1.0 0.6 glColor4f first2 glVertex2f ] 2each
+ glEnd ;
+
+: left ( gadget -- dim ) screen-loc first ;
+: right ( gadget -- dim ) [ screen-loc first ] [ dim>> first ] bi + ;
+
+: default-value ( side -- x )
+ \ left = 10000 0 ? ;
+
+: compare ( x y side -- ? )
+ \ left = [ 3 - < ] [ 3 + > ] if ;
+
+:: above ( gadget side -- dim )
+ gadget parent>> gadget-child children>> [ empty? not ]
+ [ side \ left = [ first ] [ last ] if children>> second side execute( x -- x ) ]
+ [ side default-value ] smart-if* ;
+
+:: below ( gadget side -- dim )
+ gadget parent>> parent>>
+ [ dup parent>> children>> { [ length 1 > nip ] [ second = not ] } 2&& ]
+ [ parent>> children>> second side execute( x -- x ) ]
+ [ side default-value ] smart-if* ;
+
+:: above-wider? ( gadget side -- ? )
+ gadget [ side above ] [ side execute( x -- x ) ] bi side compare ;
+
+:: below-wider? ( gadget side -- ? )
+ gadget [ side below ] [ side execute( x -- x ) ] bi side compare ;
+
+:: find-half-shape ( gadget side -- shape ) {
+ { [ gadget left 10 < ] [ [ squircle ] ] }
+ { [ gadget side above-wider? gadget side below-wider? and ] [ [ 6 wide-narrow-wide ] ] }
+ { [ gadget side above-wider? gadget side below-wider? not and ] [ [ 6 wide-narrow ] ] }
+ { [ gadget side above-wider? not gadget side below-wider? and ] [ [ 6 narrow-wide ] ] }
+ { [ gadget side above-wider? not gadget side below-wider? not and ] [ [ 6 narrow-wide-narrow ] ] }
+ } cond ;
+
+: find-shape ( gadget -- left-shape right-shape )
+ [ \ left find-half-shape ] [ \ right find-half-shape ] bi ;
+
+:: (recompute-pen) ( gadget gradient left-shape right-shape symmetric? -- )
+ gadget dim>> dup left-shape right-shape symmetric? vertices dup gradient last-vertices<<
+ gradient colors>> vertices-colors gradient last-colors<< ;
+
+M: gradient-squircle recompute-pen ( gadget gradient -- )
+ [ squircle ] dup t (recompute-pen) ;
+
+M: gradient-arrow recompute-pen ( gadget gradient -- )
+ [ arrow ] dup f (recompute-pen) ;
+
+M: gradient-pointy recompute-pen ( gadget gradient -- )
+ [ 1.5 narrow-wide-narrow ] dup t (recompute-pen) ;
+
+M:: gradient-dynamic-shape recompute-pen ( gadget gradient -- )
+ gadget gradient gadget find-shape t (recompute-pen) ;
+
+PRIVATE>
+
+M: gradient-shape draw-interior
+ [ compute-pen ]
+ [ last-vertices>> ]
+ [ last-colors>> draw-triangle-fan ] tri ;
+
+M: gradient-shape pen-background
+ 2drop transparent ;
+
+M: gradient-shape pen-foreground
+ nip foreground>> ;
+
+M: gradient-dynamic-shape draw-interior
+ [ call-next-method ]
+ [ selected?>> ]
+ [ last-vertices>> ] tri
+ [ draw-triangle-fan-selected ] curry when ;
+
+IN: ui.pens.title-gradient
+
+TUPLE: title-gradient colors foreground selected? ;
+
+: <title-gradient> ( colors foreground selected? -- gradient )
+ title-gradient new swap >>selected? swap >>foreground swap >>colors ;
+
+:: draw-gradient ( dim gradient -- )
+ GL_QUADS glBegin
+ gradient first >rgba-components glColor4f
+ 0.0 0.0 glVertex2f
+ dim first 0.0 glVertex2f
+ gradient second >rgba-components glColor4f
+ dim first2 glVertex2f
+ 0.0 dim second glVertex2f
+ glEnd ;
+
+:: draw-underline ( dim gradient -- )
+ 1 gl-scale glLineWidth
+ GL_LINES glBegin
+ gradient first >rgba-components glColor4f
+ 0.0 dim second glVertex2f
+ dim first2 glVertex2f
+ glEnd ;
+
+CONSTANT: shadow-width 20.0
+
+:: draw-shadows ( dim -- )
+ GL_QUADS glBegin
+ content-background-colour >rgba-components glColor4f
+ 0.0 0.0 glVertex2f
+ 0.0 dim second 1 + glVertex2f
+ content-background-colour >rgba-components drop 0.0 glColor4f
+ shadow-width dim second 1 + glVertex2f
+ shadow-width 0.0 glVertex2f
+ content-background-colour >rgba-components glColor4f
+ dim first 0.0 glVertex2f
+ dim first dim second 1 + glVertex2f
+ content-background-colour >rgba-components drop 0.0 glColor4f
+ dim first shadow-width - dim second 1 + glVertex2f
+ dim first shadow-width - 0.0 glVertex2f
+ glEnd ;
+
+: draw-title ( dim gradient -- )
+ [ draw-gradient ] [ draw-underline ] [ drop draw-shadows ] 2tri ;
+
+M: title-gradient draw-interior
+ [ dim>> ] dip colors>> draw-title ;
+
+M: title-gradient pen-background
+ 2drop transparent ;
+
+M: title-gradient pen-foreground
+ nip foreground>> ;
projects / factor.git / commitdiff
