USING: help.markup help.syntax ui.gadgets ui.gadgets.labels
-ui.render kernel models classes ;
+ui.pens kernel models classes ;
IN: ui.gadgets.buttons
HELP: button
classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
-ui.render math.rectangles locals alien.c-types
+ui.pens ui.pens.solid ui.pens.caching math.rectangles locals
specialized-arrays.float fry combinators.smart ;
IN: ui.gadgets.buttons
continuations ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
ui.gadgets.theme ui.gadgets.menus ui.gadgets.wrappers ui.render
-ui.gadgets.line-support ui.text ui.gestures math.rectangles splitting
-unicode.categories fonts ;
+ui.pens.solid ui.gadgets.line-support ui.text ui.gestures
+math.rectangles splitting unicode.categories fonts ;
IN: ui.gadgets.editors
TUPLE: editor < gadget
USING: ui.gadgets help.markup help.syntax ui.gadgets.grids
-ui.render colors ;
+ui.pens colors ;
IN: ui.gadgets.grid-lines
HELP: grid-lines
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math namespaces opengl opengl.gl
-sequences math.vectors ui.gadgets ui.gadgets.grids
+sequences math.vectors ui.pens ui.gadgets ui.gadgets.grids
ui.gadgets.grids.private ui.render math.rectangles
fry locals arrays assocs ;
IN: ui.gadgets.grid-lines
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors ui.images ui.render ui.gadgets ;
+USING: kernel accessors ui.images ui.pens
+ui.pens.image ui.gadgets ;
IN: ui.gadgets.icons
TUPLE: icon < gadget ;
{ $values { "gadget" gadget } { "title" string } { "newgadget" "a new " { $link <labelled-gadget> } } }
{ $description "Creates a new " { $link labelled-gadget } " display " { $snippet "gadget" } " with " { $snippet "title" } " on top." } ;
-HELP: closable-gadget
-{ $class-description "A closable gadget displays a title bar with a close box on top of another gadget. Clicking the close box invokes a quotation. Closable gadgets are created by calling " { $link <closable-gadget> } "." } ;
-
-HELP: <closable-gadget>
-{ $values { "gadget" gadget } { "title" string } { "quot" { $quotation "( button -- )" } } }
-{ $description "Creates a new " { $link closable-gadget } ". Clicking the close box calls " { $snippet "quot" } "." }
-{ $notes "The quotation can find the " { $link closable-gadget } " instance, or any other parent gadget by calling " { $link find-parent } " with the gadget it receives on the stack." } ;
-
HELP: <labelled-pane>
{ $values { "model" model } { "quot" { $quotation "( value -- )" } } { "scrolls?" "a boolean" } { "title" string } { "gadget" "a new " { $link gadget } } }
{ $description "Creates a new control delegating to a " { $link pane } ", and wraps it in a " { $link labelled-gadget } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
ARTICLE: "ui.gadgets.labelled" "Labelled gadgets"
"The " { $vocab-link "ui.gadgets.labelled" } " vocabulary implements labelled borders around child gadgets."
{ $subsection labelled-gadget }
-{ $subsection <labelled-gadget> }
-"Or a labelled border with a close box:"
-{ $subsection closable-gadget }
-{ $subsection <closable-gadget> } ;
+{ $subsection <labelled-gadget> } ;
ABOUT: "ui.gadgets.labelled"
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables io kernel math math.functions
namespaces make opengl sequences strings splitting ui.gadgets
-ui.gadgets.tracks ui.gadgets.packs fonts ui.render ui.text
-colors colors.constants models combinators ;
+ui.gadgets.tracks ui.gadgets.packs fonts ui.render ui.pens.solid
+ui.text colors colors.constants models combinators ;
IN: ui.gadgets.labels
! A label gadget draws a string.
-USING: help.markup help.syntax ui.gadgets models models.range ;
+USING: help.markup help.syntax ui.gadgets models models.range
+ui.gadgets.sliders.private ;
IN: ui.gadgets.sliders
HELP: elevator
USING: accessors arrays assocs kernel math namespaces sequences
vectors models models.range math.vectors math.functions quotations
colors colors.constants math.rectangles fry combinators ui.gestures
-ui.gadgets ui.gadgets.buttons ui.gadgets.tracks math.order
-ui.gadgets.theme ui.gadgets.icons ui.render ;
+ui.pens ui.gadgets ui.gadgets.buttons ui.gadgets.tracks math.order
+ui.gadgets.theme ui.gadgets.icons ui.pens.tile ui.pens.image ;
IN: ui.gadgets.sliders
TUPLE: slider < track elevator thumb saved line ;
! Copyright (C) 2005, 2009 Slava Pestov.
! Copyright (C) 2006, 2007 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences ui.gadgets ui.render
-ui.text colors colors.gray colors.constants accessors ;
+USING: arrays kernel sequences ui.gadgets ui.pens.solid
+ui.pens.gradient ui.text ui.images colors colors.gray
+colors.constants accessors io.pathnames ;
QUALIFIED: colors
IN: ui.gadgets.theme
+: theme-image ( name -- image-name )
+ "resource:basis/ui/gadgets/theme/" prepend-path ".tiff" append <image-name> ;
+
: solid-interior ( gadget color -- gadget )
<solid> >>interior ; inline
USING: ui.gadgets ui.render ui.text ui.text.private
ui.gestures ui.backend help.markup help.syntax
-models opengl opengl.sprites strings ;
+models opengl strings ;
IN: ui.gadgets.worlds
HELP: user-input
-USING: ui.gadgets ui.gadgets.worlds help.markup help.syntax
+USING: ui.gadgets help.markup help.syntax
hashtables strings kernel system ;
IN: ui.gestures
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test ui.pens.caching ;
+IN: ui.pens.caching.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel ;
+IN: ui.pens.caching
+
+! A pen that caches vertex arrays, etc
+TUPLE: caching-pen last-dim ;
+
+GENERIC: recompute-pen ( gadget pen -- )
+
+: compute-pen ( gadget pen -- )
+ 2dup [ dim>> ] [ last-dim>> ] bi* eq? [
+ 2drop
+ ] [
+ [ swap dim>> >>last-dim drop ] [ recompute-pen ] 2bi
+ ] if ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: ui.pens.gradient
+USING: help.markup help.syntax ui.pens colors ;
+
+HELP: gradient
+{ $class-description "A class implementing the " { $link draw-interior } " generic word to draw a smoothly shaded transition between colors. The " { $snippet "colors" } " slot stores a sequence of " { $link color } " instances, and the gradient is drawn in the direction given by the " { $snippet "orientation" } " slot of the gadget." }
+{ $notes "See " { $link "colors" } "." } ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test ui.pens.gradient ;
+IN: ui.pens.gradient.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors math math.vectors locals sequences
+specialized-arrays.float colors arrays combinators
+opengl opengl.gl ui.pens ui.pens.caching ;
+IN: ui.pens.gradient
+
+! Gradient pen
+TUPLE: gradient < caching-pen colors last-vertices last-colors ;
+
+: <gradient> ( colors -- gradient ) gradient new swap >>colors ;
+
+<PRIVATE
+
+:: gradient-vertices ( direction dim colors -- seq )
+ direction dim v* dim over v- swap
+ colors length dup 1- v/n [ v*n ] with map
+ swap [ over v+ 2array ] curry map
+ concat concat >float-array ;
+
+: gradient-colors ( colors -- seq )
+ [ >rgba-components 4array dup 2array ] map concat concat
+ >float-array ;
+
+M: gradient recompute-pen ( gadget gradient -- )
+ [ nip ] [ [ [ orientation>> ] [ dim>> ] bi ] [ colors>> ] bi* ] 2bi
+ [ gradient-vertices >>last-vertices ]
+ [ gradient-colors >>last-colors ]
+ bi drop ;
+
+: draw-gradient ( colors -- )
+ GL_COLOR_ARRAY [
+ [ GL_QUAD_STRIP 0 ] dip length 2 * glDrawArrays
+ ] do-enabled-client-state ;
+
+PRIVATE>
+
+M: gradient draw-interior
+ {
+ [ compute-pen ]
+ [ last-vertices>> gl-vertex-pointer ]
+ [ last-colors>> gl-color-pointer ]
+ [ colors>> draw-gradient ]
+ } cleave ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test ui.pens.image ;
+IN: ui.pens.image.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences fry math
+opengl ui.pens ui.images ;
+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/ ] 2map ] keep
+ '[ _ draw-image ] with-translation
+ ] if ;
+
+M: image-pen pen-pref-dim nip image>> image-dim ;
\ No newline at end of file
--- /dev/null
+IN: ui.pens
+USING: help.markup help.syntax kernel ui.gadgets ;
+
+HELP: draw-interior
+{ $values { "interior" object } { "gadget" gadget } }
+{ $contract "Draws the interior of a gadget by making OpenGL calls. The " { $snippet "interior" } " slot may be set to objects implementing this generic word." } ;
+
+HELP: draw-boundary
+{ $values { "boundary" object } { "gadget" gadget } }
+{ $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $snippet "boundary" } " slot may be set to objects implementing this generic word." } ;
+
+ARTICLE: "ui-pen-protocol" "UI pen protocol"
+"The " { $snippet "interior" } " and " { $snippet "boundary" } " slots of a gadget facilitate easy factoring and sharing of drawing logic. Objects stored in these slots must implement the pen protocol:"
+{ $subsection draw-interior }
+{ $subsection draw-boundary }
+"The default value of these slots is the " { $link f } " singleton, which implements the above protocol by doing nothing."
+$nl
+"Some other pre-defined implementations:"
+{ $vocab-subsection "ui.pens.gradient" }
+{ $vocab-subsection "ui.pens.image" }
+{ $vocab-subsection "ui.pens.polygon" }
+{ $vocab-subsection "ui.pens.solid" }
+{ $vocab-subsection "ui.pens.tile" }
+"Custom implementations must follow the guidelines set forth in " { $link "ui-paint-custom" } "." ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test ui.pens ;
+IN: ui.pens.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel ;
+IN: ui.pens
+
+GENERIC: draw-interior ( gadget interior -- )
+
+GENERIC: draw-boundary ( gadget boundary -- )
+
+GENERIC: pen-pref-dim ( gadget pen -- dim )
+
+M: object pen-pref-dim 2drop { 0 0 } ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: ui.pens.polygon
+USING: help.markup help.syntax ;
+
+HELP: polygon
+{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid filled polygon, respectively. Instances of " { $link polygon } " have two slots:"
+ { $list
+ { { $snippet "color" } " - a " { $link color } }
+ { { $snippet "points" } " - a sequence of points" }
+ }
+} ;
+
+HELP: <polygon>
+{ $values { "color" color } { "points" "a sequence of points" } { "polygon" polygon } }
+{ $description "Creates a new instance of " { $link polygon } "." } ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test ui.pens.polygon ;
+IN: ui.pens.polygon.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ;
+IN: ui.pens.polygon
+
+! Polygon pen
+TUPLE: polygon color
+interior-vertices
+interior-count
+boundary-vertices
+boundary-count ;
+
+: <polygon> ( color points -- polygon )
+ dup close-path [ [ concat >float-array ] [ length ] bi ] bi@
+ polygon boa ;
+
+M: polygon draw-boundary
+ nip
+ [ color>> gl-color ]
+ [ boundary-vertices>> gl-vertex-pointer ]
+ [ [ GL_LINE_STRIP 0 ] dip boundary-count>> glDrawArrays ]
+ tri ;
+
+M: polygon draw-interior
+ nip
+ [ color>> gl-color ]
+ [ interior-vertices>> gl-vertex-pointer ]
+ [ [ GL_POLYGON 0 ] dip interior-count>> glDrawArrays ]
+ tri ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: ui.pens.solid
+USING: help.markup help.syntax ui.pens colors ;
+
+HELP: solid
+{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid fill, respectively. The " { $snippet "color" } " slot stores an instance of " { $link color } "." }
+{ $notes "See " { $link "colors" } "." } ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test ui.pens.solid ;
+IN: ui.pens.solid.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors opengl ui.pens ui.pens.caching ;
+IN: ui.pens.solid
+
+! Solid fill/border
+TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
+
+: <solid> ( color -- solid ) solid new swap >>color ;
+
+M: solid recompute-pen
+ swap dim>>
+ [ (fill-rect-vertices) >>interior-vertices ]
+ [ (rect-vertices) >>boundary-vertices ]
+ bi drop ;
+
+<PRIVATE
+
+! Solid pen
+: (solid) ( gadget pen -- )
+ [ compute-pen ] [ color>> gl-color ] bi ;
+
+PRIVATE>
+
+M: solid draw-interior
+ [ (solid) ] [ interior-vertices>> gl-vertex-pointer ] bi
+ (gl-fill-rect) ;
+
+M: solid draw-boundary
+ [ (solid) ] [ boundary-vertices>> gl-vertex-pointer ] bi
+ (gl-rect) ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test ui.pens.tile ;
+IN: ui.pens.tile.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors math.vectors ui.images opengl fry
+combinators ui.pens ;
+IN: ui.pens.tile
+
+! Tile pen
+TUPLE: tile-pen left center right ;
+
+: <tile-pen> ( left center right -- pen )
+ tile-pen boa ;
+
+: >tile-pen< ( pen -- left center right )
+ [ left>> ] [ center>> ] [ right>> ] tri ; inline
+
+M: tile-pen pen-pref-dim
+ swap [
+ >tile-pen< [ image-dim ] tri@
+ [ vmax vmax ] [ v+ v+ ] 3bi
+ ] dip orientation>> set-axis ;
+
+: compute-tile-xs ( gadget pen -- x1 x2 x3 )
+ [ 2drop { 0 0 } ]
+ [ nip left>> image-dim ]
+ [ [ dim>> ] [ right>> image-dim ] bi* v- ]
+ 2tri ;
+
+: compute-tile-widths ( gadget pen -- w1 w2 w3 )
+ [ nip left>> image-dim ]
+ [ [ dim>> ] [ [ left>> ] [ right>> ] bi [ image-dim ] bi@ ] bi* v+ v- ]
+ [ nip right>> image-dim ]
+ 2tri ;
+
+: render-tile ( tile x width gadget -- )
+ [ orientation>> '[ _ v* ] dip ] keep
+ '[
+ _ _ [ dim>> swap ] [ orientation>> ] bi set-axis
+ swap draw-scaled-image
+ ] with-translation ;
+
+M: tile-pen draw-interior ( gadget pen -- )
+ {
+ [ nip >tile-pen< ]
+ [ compute-tile-xs ]
+ [ compute-tile-widths ]
+ [ drop ]
+ } 2cleave
+ [ render-tile ] curry tri-curry@ tri-curry* tri* ;
\ No newline at end of file
-USING: ui.gadgets ui.gestures help.markup help.syntax
+USING: ui.gadgets ui.pens ui.gestures help.markup help.syntax
kernel classes strings opengl opengl.gl models
math.rectangles math colors ;
IN: ui.render
{ { $snippet "visible?" } " - a boolean indicating if the gadget should display and receive user input." }
{ { $snippet "root?" } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
{ { $snippet "clipped?" } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
- { { $snippet "interior" } " - an object whose class implements the " { $link draw-interior } " generic word." }
- { { $snippet "boundary" } " - an object whose class implements the " { $link draw-boundary } " generic word." }
+ { { $snippet "interior" } " - an implementation of the " { $link "ui-pen-protocol" } }
+ { { $snippet "boundary" } " - an implementation of the " { $link "ui-pen-protocol" } }
{ { $snippet "model" } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
}
"Gadgets subclass the " { $link rect } " class, and thus all instances have " { $snippet "loc" } " and " { $snippet "dim" } " instances holding their location and dimensions." }
{ $contract "Draws the gadget by making OpenGL calls. The top-left corner of the gadget should be drawn at the location stored in the " { $link origin } " variable." }
{ $notes "This word should not be called directly. To force a gadget to redraw, call " { $link relayout-1 } "." } ;
-HELP: draw-interior
-{ $values { "interior" object } { "gadget" gadget } }
-{ $contract "Draws the interior of a gadget by making OpenGL calls. The " { $snippet "interior" } " slot may be set to objects implementing this generic word." } ;
-
-HELP: draw-boundary
-{ $values { "boundary" object } { "gadget" gadget } }
-{ $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $snippet "boundary" } " slot may be set to objects implementing this generic word." } ;
-
-HELP: solid
-{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid fill, respectively. The " { $snippet "color" } " slot stores an instance of " { $link color } "." }
-{ $notes "See " { $link "colors" } "." } ;
-
-HELP: gradient
-{ $class-description "A class implementing the " { $link draw-interior } " generic word to draw a smoothly shaded transition between colors. The " { $snippet "colors" } " slot stores a sequence of " { $link color } " instances, and the gradient is drawn in the direction given by the " { $snippet "orientation" } " slot of the gadget." }
-{ $notes "See " { $link "colors" } "." } ;
-
-HELP: polygon
-{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid filled polygon, respectively. Instances of " { $link polygon } " have two slots:"
- { $list
- { { $snippet "color" } " - a " { $link color } }
- { { $snippet "points" } " - a sequence of points" }
- }
-} ;
-
-HELP: <polygon>
-{ $values { "color" color } { "points" "a sequence of points" } { "polygon" polygon } }
-{ $description "Creates a new instance of " { $link polygon } "." } ;
-
-HELP: <polygon-gadget>
-{ $values { "color" color } { "points" "a sequence of points" } { "gadget" "a new " { $link gadget } } }
-{ $description "Creates a gadget which is drawn as a solid filled polygon. The gadget's size is the minimum bounding box containing all the points of the polygon." } ;
-
-ARTICLE: "gadgets-polygons" "Polygon gadgets"
-"A polygon gadget renders a simple shaded polygon."
-{ $subsection <polygon-gadget> }
-"Some pre-made polygons:"
-{ $subsection arrow-up }
-{ $subsection arrow-right }
-{ $subsection arrow-down }
-{ $subsection arrow-left }
-{ $subsection close-box }
-"Polygon gadgets are rendered by the " { $link polygon } " pen protocol implementation." ;
-
ARTICLE: "ui-paint" "Customizing gadget appearance"
"The UI carries out the following steps when drawing a gadget:"
{ $list
{ $subsection "ui-pen-protocol" }
{ $subsection "ui-paint-custom" } ;
-ARTICLE: "ui-pen-protocol" "UI pen protocol"
-"The " { $snippet "interior" } " and " { $snippet "boundary" } " slots of a gadget facilitate easy factoring and sharing of drawing logic. Objects stored in these slots must implement the pen protocol:"
-{ $subsection draw-interior }
-{ $subsection draw-boundary }
-"The default value of these slots is the " { $link f } " singleton, which implements the above protocol by doing nothing."
-$nl
-"Some other pre-defined implementations:"
-{ $subsection solid }
-{ $subsection gradient }
-{ $subsection polygon }
-"Custom implementations must follow the guidelines set forth in " { $link "ui-paint-custom" } "." ;
-
ARTICLE: "ui-paint-coord" "The UI co-ordinate system"
-"The UI uses a co-ordinate system where the y axis is oriented down. The OpenGL " { $link GL_MODELVIEW } " matrix is not saved or restored when rendering a gadget. Instead, the origin of the gadget relative to the OpenGL context is stored in a variable:"
+"The UI uses a co-ordinate system where the y axis is oriented down. The OpenGL " { $link GL_MODELVIEW } " matrix is saved or restored when rendering a gadget, and the origin is translated to the gadget's origin within the window. The current origin is stored in a variable:"
{ $subsection origin }
-"Custom drawing implementations can translate co-ordinates manually, or save and restore the " { $link GL_MODELVIEW } " matrix using a word such as " { $link with-translation } "."
-$nl
"Gadgets must not draw outside of their bounding box, however clipping is not enforced by default, for performance reasons. This can be changed by setting the " { $slot "clipped?" } " slot to " { $link t } " in the gadget's constructor." ;
ABOUT: "ui-paint"
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays hashtables io io.pathnames
-kernel math namespaces opengl opengl.gl opengl.glu sequences strings
-vectors combinators math.vectors ui.gadgets ui.images colors fry
-colors.constants math.order math.rectangles locals
-specialized-arrays.float ;
+USING: math.rectangles math.vectors namespaces kernel accessors
+combinators sequences opengl opengl.gl opengl.glu colors.constants
+ui.gadgets ui.pens ;
IN: ui.render
SYMBOL: clip
M: gadget draw-gadget* drop ;
-GENERIC: draw-interior ( gadget interior -- )
-
-GENERIC: draw-boundary ( gadget boundary -- )
-
-GENERIC: pen-pref-dim ( gadget pen -- dim )
-
-M: object pen-pref-dim 2drop { 0 0 } ;
-
SYMBOL: origin
{ 0 0 } origin set-global
{ [ dup visible?>> not ] [ drop ] }
{ [ dup clipped?>> not ] [ (draw-gadget) ] }
[ [ (draw-gadget) ] with-clipping ]
- } cond ;
-
-! A pen that caches vertex arrays, etc
-TUPLE: caching-pen last-dim ;
-
-GENERIC: recompute-pen ( gadget pen -- )
-
-: compute-pen ( gadget pen -- )
- 2dup [ dim>> ] [ last-dim>> ] bi* = [
- 2drop
- ] [
- [ swap dim>> >>last-dim drop ] [ recompute-pen ] 2bi
- ] if ;
-
-! Solid fill/border
-TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
-
-: <solid> ( color -- solid ) solid new swap >>color ;
-
-M: solid recompute-pen
- swap dim>>
- [ (fill-rect-vertices) >>interior-vertices ]
- [ (rect-vertices) >>boundary-vertices ]
- bi drop ;
-
-<PRIVATE
-
-! Solid pen
-: (solid) ( gadget pen -- )
- [ compute-pen ] [ color>> gl-color ] bi ;
-
-PRIVATE>
-
-M: solid draw-interior
- [ (solid) ] [ interior-vertices>> gl-vertex-pointer ] bi
- (gl-fill-rect) ;
-
-M: solid draw-boundary
- [ (solid) ] [ boundary-vertices>> gl-vertex-pointer ] bi
- (gl-rect) ;
-
-! Gradient pen
-TUPLE: gradient < caching-pen colors last-vertices last-colors ;
-
-: <gradient> ( colors -- gradient ) gradient new swap >>colors ;
-
-<PRIVATE
-
-:: gradient-vertices ( direction dim colors -- seq )
- direction dim v* dim over v- swap
- colors length dup 1- v/n [ v*n ] with map
- swap [ over v+ 2array ] curry map
- concat concat >float-array ;
-
-: gradient-colors ( colors -- seq )
- [ >rgba-components 4array dup 2array ] map concat concat
- >float-array ;
-
-M: gradient recompute-pen ( gadget gradient -- )
- [ nip ] [ [ [ orientation>> ] [ dim>> ] bi ] [ colors>> ] bi* ] 2bi
- [ gradient-vertices >>last-vertices ]
- [ gradient-colors >>last-colors ]
- bi drop ;
-
-: draw-gradient ( colors -- )
- GL_COLOR_ARRAY [
- [ GL_QUAD_STRIP 0 ] dip length 2 * glDrawArrays
- ] do-enabled-client-state ;
-
-PRIVATE>
-
-M: gradient draw-interior
- {
- [ compute-pen ]
- [ last-vertices>> gl-vertex-pointer ]
- [ last-colors>> gl-color-pointer ]
- [ colors>> draw-gradient ]
- } cleave ;
-
-! Polygon pen
-TUPLE: polygon color
-interior-vertices
-interior-count
-boundary-vertices
-boundary-count ;
-
-: <polygon> ( color points -- polygon )
- dup close-path [ [ concat >float-array ] [ length ] bi ] bi@
- polygon boa ;
-
-M: polygon draw-boundary
- nip
- [ color>> gl-color ]
- [ boundary-vertices>> gl-vertex-pointer ]
- [ [ GL_LINE_STRIP 0 ] dip boundary-count>> glDrawArrays ]
- tri ;
-
-M: polygon draw-interior
- nip
- [ color>> gl-color ]
- [ interior-vertices>> gl-vertex-pointer ]
- [ [ GL_POLYGON 0 ] dip interior-count>> glDrawArrays ]
- tri ;
-
-: theme-image ( name -- image-name )
- "resource:basis/ui/gadgets/theme/" prepend-path ".tiff" append <image-name> ;
-
-! 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/ ] 2map ] keep
- '[ _ draw-image ] with-translation
- ] if ;
-
-M: image-pen pen-pref-dim nip image>> image-dim ;
-
-! Tile pen
-TUPLE: tile-pen left center right ;
-
-: <tile-pen> ( left center right -- pen )
- tile-pen boa ;
-
-: >tile-pen< ( pen -- left center right )
- [ left>> ] [ center>> ] [ right>> ] tri ; inline
-
-M: tile-pen pen-pref-dim
- swap [
- >tile-pen< [ image-dim ] tri@
- [ vmax vmax ] [ v+ v+ ] 3bi
- ] dip orientation>> set-axis ;
-
-: compute-tile-xs ( gadget pen -- x1 x2 x3 )
- [ 2drop { 0 0 } ]
- [ nip left>> image-dim ]
- [ [ dim>> ] [ right>> image-dim ] bi* v- ]
- 2tri ;
-
-: compute-tile-widths ( gadget pen -- w1 w2 w3 )
- [ nip left>> image-dim ]
- [ [ dim>> ] [ [ left>> ] [ right>> ] bi [ image-dim ] bi@ ] bi* v+ v- ]
- [ nip right>> image-dim ]
- 2tri ;
-
-: render-tile ( tile x width gadget -- )
- [ orientation>> '[ _ v* ] dip ] keep
- '[
- _ _ [ dim>> swap ] [ orientation>> ] bi set-axis
- swap draw-scaled-image
- ] with-translation ;
-
-M: tile-pen draw-interior ( gadget pen -- )
- {
- [ nip >tile-pen< ]
- [ compute-tile-xs ]
- [ compute-tile-widths ]
- [ drop ]
- } 2cleave
- [ render-tile ] curry tri-curry@ tri-curry* tri* ;
\ No newline at end of file
+ } cond ;
\ No newline at end of file
ui.commands ui.operations ui.gadgets ui.gadgets.editors
ui.gadgets.glass ui.gadgets.scrollers ui.gadgets.tables
ui.gadgets.tracks ui.gadgets.labelled ui.gadgets.theme
-ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.render
+ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.pens.solid
ui.tools.listener.history combinators vocabs ui.tools.listener.popups ;
IN: ui.tools.listener.completion
io.styles kernel lexer listener math models models.delay models.filter
namespaces parser prettyprint quotations sequences strings threads
tools.vocabs vocabs vocabs.loader vocabs.parser words ui ui.commands
-ui.render ui.gadgets ui.gadgets.buttons ui.gadgets.editors
+ui.pens.solid ui.gadgets ui.gadgets.buttons ui.gadgets.editors
ui.gadgets.labelled ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures
ui.operations ui.tools.browser ui.tools.common ui.tools.debugger
projects / factor.git / commitdiff