USING: classes kernel parser words ;
-IN: classes.parser
+IN: skov.basis.classes.parser
: create-class ( string vocab -- word )
create-word dup t "defining-class" set-word-prop
ui.gadgets vectors vocabs.parser definitions ;
QUALIFIED: vocabs
QUALIFIED: words
-IN: code
+IN: skov.basis.code
TUPLE: element < identity-tuple name parent contents default-name target ;
! 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
+USING: accessors arrays assocs classes.parser classes.tuple
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 ;
+sequences sequences.deep sets skov.basis.code splitting
+ui.gadgets.panes vocabs.parser ;
+
+FROM: skov.basis.code => call ;
QUALIFIED: words
QUALIFIED: vocabs
-IN: code.execution
+IN: skov.basis.code.execution
: effect ( def -- effect )
[ introduces [ name>> empty? ] reject ] [ returns ] bi
kernel locals math math.parser quotations sequences splitting
stack-checker strings vectors words ;
FROM: code => call word ;
-IN: code.factor-abstraction
+IN: skov.basis.code.factor-abstraction
:: call-from-factor ( factor-word -- call )
call new factor-word name>> >>name factor-word >>target ;
! 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
+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
+skov.basis.code skov.basis.code.execution system ui.gadgets ;
+FROM: skov.basis.code => call ;
+IN: skov.basis.code.import-export
SYMBOL: skov-version
+++ /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"
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors colors combinators kernel math namespaces ;
-IN: fonts
+IN: skov.basis.fonts
CONSTANT: default-serif-font-name "serif"
CONSTANT: default-sans-serif-font-name "Linux Biolinum O" inline
+++ /dev/null
-Fonts as a first-class data type
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
+IN: skov.basis.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."
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
+IN: skov.basis.help
GENERIC: word-help* ( word -- content )
sequences.private sets sorting splitting strings urls vocabs
words words.symbol ;
FROM: prettyprint.sections => with-pprint ;
-IN: help.markup
+IN: skov.basis.help.markup
PREDICATE: simple-element < array
[ t ] [ first word? not ] if-empty ;
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USE: math
-IN: math.constants
+IN: skov.basis.math.constants
: e ( -- e ) 2.7182818284590452354 ; inline
: euler ( -- gamma ) 0.57721566490153286060 ; inline
! 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
+IN: skov.basis.ui.commands
SYMBOL: +nullary+
SYMBOL: +listener+
! 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
+USING: accessors skov.basis.code.execution combinators.smart help.topics
+kernel locals models ui.gadgets skov.basis.ui.gadgets.buttons.round
+ui.gadgets.packs skov.basis.ui.tools.environment.theme vocabs words ;
+IN: skov.basis.ui.gadgets.buttons.activate
: vocab/word? ( obj -- ? )
[ vocab? ] [ [ link? ] [ name>> word? ] [ drop f ] smart-if ] bi or ;
! 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
+skov.basis.ui.pens.gradient-rounded
+skov.basis.ui.tools.environment.theme ;
+IN: skov.basis.ui.gadgets.buttons.round
TUPLE: round-button < button ;
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
+skov.basis.ui.pens.gradient system ;
+IN: skov.basis.ui.pens.gradient-rounded
TUPLE: gradient-shape < caching-pen colors foreground shape last-vertices last-colors ;
TUPLE: gradient-squircle < gradient-shape ;
USING: accessors colors kernel locals math opengl opengl.gl
-sequences ui.pens ui.tools.environment.theme system ;
-IN: ui.pens.title-gradient
+sequences ui.pens skov.basis.ui.tools.environment.theme system ;
+IN: skov.basis.ui.pens.title-gradient
TUPLE: title-gradient colors foreground selected? ;
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
+IN: skov.basis.ui.gadgets.sliders
TUPLE: slider < track elevator thumb saved line ;
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
+IN: skov.basis.ui.images
TUPLE: image-name path ;
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
+IN: skov.basis.ui.pens.gradient-rounded
TUPLE: gradient-shape < caching-pen colors foreground shape last-vertices last-colors ;
TUPLE: gradient-squircle < gradient-shape ;
! 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
+IN: skov.basis.ui.pens.image
! Image pen
TUPLE: image-pen image fill? ;
--- /dev/null
+USING: accessors colors kernel math opengl opengl.gl sequences
+skov.basis.ui.tools.environment.theme ui.pens ;
+IN: skov.basis.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>> ;
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
+ui.tools.common unicode vocabs skov.basis.ui.gadgets.buttons.activate ;
+IN: skov.basis.ui.tools.browser
TUPLE: browser-gadget < tool history scroller search-field popup ;
! 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 ;
+USING: accessors arrays colors combinators combinators.short-circuit
+combinators.smart kernel listener math models sequences
+skov.basis.code skov.basis.code.execution
+skov.basis.ui.gadgets.buttons.round
+skov.basis.ui.pens.gradient-rounded skov.basis.ui.pens.title-gradient
+skov.basis.ui.tools.browser skov.basis.ui.tools.environment.theme
+ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.editors
+ui.gadgets.labels ui.gadgets.packs ui.gestures ;
+FROM: skov.basis.code => call ;
FROM: models => change-model ;
-IN: ui.tools.environment.cell
+IN: skov.basis.ui.tools.environment.cell
CONSTANT: cell-height 24
CONSTANT: min-cell-width 30
! 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
+USING: accessors kernel memory models namespaces skov.basis.code
+skov.basis.code.import-export skov.basis.ui.tools.browser
+skov.basis.ui.tools.environment.navigation
+skov.basis.ui.tools.environment.theme 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 ;
+ui.gadgets.worlds ui.gestures ui.pixel-formats ui.tools.common ;
+
FROM: models => change-model ;
-IN: ui.tools.environment
+IN: skov.basis.ui.tools.environment
TUPLE: environment < tool ;
! 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
+USING: accessors arrays colors kernel math math.functions opengl.gl
+sequences skov.basis.ui.pens.gradient-rounded.private
+skov.basis.ui.tools.environment.theme system ui.gadgets ui.render ;
+IN: skov.basis.ui.tools.environment.navigation.dot-pattern
TUPLE: dot-pattern < gadget ;
! 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 ;
+USING: accessors combinators combinators.smart kernel models sequences
+skov.basis.code skov.basis.code.execution
+skov.basis.ui.pens.gradient-rounded
+skov.basis.ui.tools.environment.cell
+skov.basis.ui.tools.environment.navigation.dot-pattern
+skov.basis.ui.tools.environment.theme
+skov.basis.ui.tools.environment.tree ui.gadgets ui.gadgets.borders
+ui.gadgets.labels ui.gadgets.packs ui.gestures ;
FROM: models => change-model ;
-IN: ui.tools.environment.navigation
+IN: skov.basis.ui.tools.environment.navigation
TUPLE: navigation < pack ;
! 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
+IN: skov.basis.ui.tools.environment.theme
CONSTANT: content-background-colour COLOR: #002b36
! 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 ;
+USING: accessors arrays skov.basis.code combinators.short-circuit kernel
+locals math math.order math.vectors models sequences
+skov.basis.ui.tools.environment.cell
+skov.basis.ui.tools.environment.theme
+skov.basis.ui.tools.environment.tree splitting ui.gadgets
+ui.gadgets.borders skov.basis.ui.gadgets.buttons.round ui.gadgets.labels
+ui.gadgets.packs ui.gadgets.packs.private ui.gestures
+skov.basis.ui.pens.gradient-rounded ui.pens.solid
+skov.basis.ui.tools.environment.theme ;
+FROM: skov.basis.code => call ;
FROM: models => change-model ;
-IN: ui.tools.environment.tree
+IN: skov.basis.ui.tools.environment.tree
TUPLE: tree < pack ;
TUPLE: tree-control < pack ;
! 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
+USING: accessors arrays assocs colors colors.gray combinators
+combinators.short-circuit combinators.smart help.topics kernel math
+math.functions math.order math.vectors models models.range opengl
+opengl.gl sequences skov.basis.code.execution
+skov.basis.ui.gadgets.buttons.round
+skov.basis.ui.pens.gradient-rounded
+skov.basis.ui.tools.environment.theme ui.gadgets ui.gadgets.buttons
+ui.gadgets.packs ui.pens ui.pens.caching vocabs words ;
+IN: skov
-: 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