Merge branch 'master' of git://factorcode.org/git/factor into mongo-factor-driver
Sascha Matzke
commit
28fa05858f
|
|
@ -4,7 +4,7 @@
|
|||
USING: accessors arrays ascii assocs calendar combinators fry kernel
|
||||
generalizations io io.encodings.ascii io.files io.streams.string
|
||||
macros math math.functions math.parser peg.ebnf quotations
|
||||
sequences splitting strings unicode.case vectors ;
|
||||
sequences splitting strings unicode.case vectors combinators.smart ;
|
||||
|
||||
IN: formatting
|
||||
|
||||
|
|
@ -113,7 +113,6 @@ MACRO: printf ( format-string -- )
|
|||
: sprintf ( format-string -- result )
|
||||
[ printf ] with-string-writer ; inline
|
||||
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-head ; inline
|
||||
|
|
@ -129,12 +128,15 @@ MACRO: printf ( format-string -- )
|
|||
[ pad-00 ] map "/" join ; inline
|
||||
|
||||
: >datetime ( timestamp -- string )
|
||||
{ [ day-of-week day-abbreviation3 ]
|
||||
[
|
||||
{
|
||||
[ day-of-week day-abbreviation3 ]
|
||||
[ month>> month-abbreviation ]
|
||||
[ day>> pad-00 ]
|
||||
[ >time ]
|
||||
[ year>> number>string ]
|
||||
} cleave 5 narray " " join ; inline
|
||||
} cleave
|
||||
] output>array " " join ; inline
|
||||
|
||||
: (week-of-year) ( timestamp day -- n )
|
||||
[ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
|
||||
|
|
@ -187,5 +189,3 @@ PRIVATE>
|
|||
MACRO: strftime ( format-string -- )
|
||||
parse-strftime [ length ] keep [ ] join
|
||||
'[ _ <vector> @ reverse concat nip ] ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -19,3 +19,9 @@ IN: literals.tests
|
|||
[ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test
|
||||
|
||||
[ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test
|
||||
|
||||
<<
|
||||
CONSTANT: constant-a 3
|
||||
>>
|
||||
|
||||
[ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
! (c) Joe Groff, see license for details
|
||||
USING: accessors continuations kernel parser words quotations vectors ;
|
||||
USING: accessors continuations kernel parser words quotations
|
||||
combinators.smart vectors sequences ;
|
||||
IN: literals
|
||||
|
||||
SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ;
|
||||
SYNTAX: $[ parse-quotation with-datastack >vector ;
|
||||
SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ;
|
||||
|
|
|
|||
|
|
@ -135,8 +135,8 @@ M: pathname pprint*
|
|||
[ text ] [ f <inset pprint* block> ] bi*
|
||||
\ } pprint-word block> ;
|
||||
|
||||
M: tuple pprint*
|
||||
boa-tuples? get [ call-next-method ] [
|
||||
: pprint-tuple ( tuple -- )
|
||||
boa-tuples? get [ pprint-object ] [
|
||||
[
|
||||
<flow
|
||||
\ T{ pprint-word
|
||||
|
|
@ -149,6 +149,9 @@ M: tuple pprint*
|
|||
] check-recursion
|
||||
] if ;
|
||||
|
||||
M: tuple pprint*
|
||||
pprint-tuple ;
|
||||
|
||||
: do-length-limit ( seq -- trimmed n/f )
|
||||
length-limit get dup [
|
||||
over length over [-]
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ threads combinators math.rectangles ;
|
|||
IN: ui.backend.cocoa.views
|
||||
|
||||
: send-mouse-moved ( view event -- )
|
||||
[ mouse-location ] [ drop window ] 2bi move-hand fire-motion ;
|
||||
[ mouse-location ] [ drop window ] 2bi move-hand fire-motion yield ;
|
||||
|
||||
: button ( event -- n )
|
||||
#! Cocoa -> Factor UI button mapping
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
USING: accessors arrays hashtables kernel models math namespaces
|
||||
make sequences quotations math.vectors combinators sorting
|
||||
binary-search vectors dlists deques models threads
|
||||
concurrency.flags math.order math.rectangles fry locals ;
|
||||
concurrency.flags math.order math.rectangles fry locals
|
||||
prettyprint.backend prettyprint.custom ;
|
||||
IN: ui.gadgets
|
||||
|
||||
! Values for orientation slot
|
||||
|
|
@ -27,6 +28,9 @@ interior
|
|||
boundary
|
||||
model ;
|
||||
|
||||
! Don't print gadgets with RECT: syntax
|
||||
M: gadget pprint* pprint-tuple ;
|
||||
|
||||
M: gadget equal? 2drop f ;
|
||||
|
||||
M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ HELP: <status-bar>
|
|||
{ $notes "If the " { $snippet "model" } " is " { $snippet "status" } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ;
|
||||
|
||||
HELP: open-status-window
|
||||
{ $values { "gadget" gadget } { "title" string } }
|
||||
{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } }
|
||||
{ $description "Like " { $link open-window } ", with the additional feature that the new window iwll have a status bar displaying the value stored in the world's " { $slot "status" } " slot." }
|
||||
{ $see-also show-status hide-status } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors models models.delay models.arrow
|
||||
sequences ui.gadgets.labels ui.gadgets.tracks
|
||||
ui.gadgets.worlds ui.gadgets ui kernel calendar summary ;
|
||||
ui.gadgets.worlds ui.gadgets ui ui.private kernel calendar summary ;
|
||||
IN: ui.gadgets.status-bar
|
||||
|
||||
: <status-bar> ( model -- gadget )
|
||||
|
|
@ -10,9 +10,9 @@ IN: ui.gadgets.status-bar
|
|||
reverse-video-theme
|
||||
t >>root? ;
|
||||
|
||||
: open-status-window ( gadget title -- )
|
||||
f <model> [ <world> ] keep
|
||||
<status-bar> f track-add
|
||||
: open-status-window ( gadget title/attributes -- )
|
||||
?attributes f <model> >>status <world>
|
||||
dup status>> <status-bar> f track-add
|
||||
open-world-window ;
|
||||
|
||||
: show-summary ( object gadget -- )
|
||||
|
|
|
|||
|
|
@ -48,8 +48,8 @@ HELP: world
|
|||
} ;
|
||||
|
||||
HELP: <world>
|
||||
{ $values { "gadget" gadget } { "title" string } { "status" model } { "world" "a new " { $link world } } }
|
||||
{ $description "Creates a new " { $link world } " delegating to the given gadget." } ;
|
||||
{ $values { "world-attributes" world-attributes } { "world" "a new " { $link world } } }
|
||||
{ $description "Creates a new " { $link world } " or world subclass with the given attributes." } ;
|
||||
|
||||
HELP: find-world
|
||||
{ $values { "gadget" gadget } { "world/f" { $maybe world } } }
|
||||
|
|
@ -65,6 +65,30 @@ HELP: find-gl-context
|
|||
{ $description "Makes the OpenGL context of the gadget's containing native window the current OpenGL context." }
|
||||
{ $notes "This word should be called from " { $link graft* } " and " { $link ungraft* } " methods which need to allocate and deallocate OpenGL resources, such as textures, display lists, and so on." } ;
|
||||
|
||||
HELP: begin-world
|
||||
{ $values { "world" world } }
|
||||
{ $description "Called immediately after " { $snippet "world" } "'s OpenGL context has been created. The world's OpenGL context is current when this method is called." } ;
|
||||
|
||||
HELP: end-world
|
||||
{ $values { "world" world } }
|
||||
{ $description "Called immediately before " { $snippet "world" } "'s OpenGL context is destroyed. The world's OpenGL context is current when this method is called." } ;
|
||||
|
||||
HELP: resize-world
|
||||
{ $values { "world" world } }
|
||||
{ $description "Called when the window containing " { $snippet "world" } " is resized. The " { $snippet "loc" } " and " { $snippet "dim" } " slots of " { $snippet "world" } " will be updated with the world's new position and size. The world's OpenGL context is current when this method is called." } ;
|
||||
|
||||
HELP: draw-world*
|
||||
{ $values { "world" world } }
|
||||
{ $description "Called when " { $snippet "world" } " needs to be redrawn. The world's OpenGL context is current when this method is called." } ;
|
||||
|
||||
ARTICLE: "ui.gadgets.worlds-subclassing" "Subclassing worlds"
|
||||
"The " { $link world } " gadget can be subclassed, giving Factor code full control of the window's OpenGL context. The following generic words can be overridden to replace standard UI behavior:"
|
||||
{ $subsection begin-world }
|
||||
{ $subsection end-world }
|
||||
{ $subsection resize-world }
|
||||
{ $subsection draw-world* }
|
||||
"See the " { $vocab-link "spheres" } " and " { $vocab-link "bunny" } " demos for examples." ;
|
||||
|
||||
ARTICLE: "ui-paint-custom" "Implementing custom drawing logic"
|
||||
"The UI uses OpenGL to render gadgets. Custom rendering logic can be plugged in with the " { $link "ui-pen-protocol" } ", or by implementing a generic word:"
|
||||
{ $subsection draw-gadget* }
|
||||
|
|
@ -72,7 +96,8 @@ ARTICLE: "ui-paint-custom" "Implementing custom drawing logic"
|
|||
$nl
|
||||
"Gadgets which need to allocate and deallocate OpenGL resources such as textures, display lists, and so on, should perform the allocation in the " { $link graft* } " method, and the deallocation in the " { $link ungraft* } " method. Since those words are not necessarily called with the gadget's OpenGL context active, a utility word can be used to find and make the correct OpenGL context current:"
|
||||
{ $subsection find-gl-context }
|
||||
"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa."
|
||||
"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa. To take full control of the OpenGL context, see " { $link "ui.gadgets.worlds-subclassing" } "."
|
||||
{ $subsection "ui-paint-coord" }
|
||||
{ $subsection "ui.gadgets.worlds-subclassing" }
|
||||
{ $subsection "gl-utilities" }
|
||||
{ $subsection "text-rendering" } ;
|
||||
|
|
|
|||
|
|
@ -4,15 +4,28 @@ USING: accessors arrays assocs continuations kernel math models
|
|||
namespaces opengl opengl.textures sequences io combinators
|
||||
combinators.short-circuit fry math.vectors math.rectangles cache
|
||||
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
|
||||
ui.commands ui.pixel-formats destructors ;
|
||||
ui.commands ui.pixel-formats destructors literals ;
|
||||
IN: ui.gadgets.worlds
|
||||
|
||||
CONSTANT: default-world-pixel-format-attributes
|
||||
{ windowed double-buffered T{ depth-bits { value 16 } } }
|
||||
|
||||
TUPLE: world < track
|
||||
active? focused?
|
||||
layers
|
||||
title status status-owner
|
||||
text-handle handle images
|
||||
window-loc ;
|
||||
active? focused?
|
||||
layers
|
||||
title status status-owner
|
||||
text-handle handle images
|
||||
window-loc
|
||||
pixel-format-attributes ;
|
||||
|
||||
TUPLE: world-attributes
|
||||
{ world-class initial: world }
|
||||
title
|
||||
status
|
||||
gadgets
|
||||
{ pixel-format-attributes initial: $ default-world-pixel-format-attributes } ;
|
||||
|
||||
C: <world-attributes> world-attributes
|
||||
|
||||
: find-world ( gadget -- world/f ) [ world? ] find-parent ;
|
||||
|
||||
|
|
@ -45,18 +58,23 @@ M: world request-focus-on ( child gadget -- )
|
|||
2dup eq?
|
||||
[ 2drop ] [ dup focused?>> (request-focus) ] if ;
|
||||
|
||||
: new-world ( gadget title status class -- world )
|
||||
: new-world ( class -- world )
|
||||
vertical swap new-track
|
||||
t >>root?
|
||||
t >>active?
|
||||
{ 0 0 } >>window-loc
|
||||
swap >>status
|
||||
swap >>title
|
||||
swap 1 track-add
|
||||
dup request-focus ;
|
||||
{ 0 0 } >>window-loc ;
|
||||
|
||||
: <world> ( gadget title status -- world )
|
||||
world new-world ;
|
||||
: apply-world-attributes ( world attributes -- world )
|
||||
{
|
||||
[ title>> >>title ]
|
||||
[ status>> >>status ]
|
||||
[ pixel-format-attributes>> >>pixel-format-attributes ]
|
||||
[ gadgets>> [ 1 track-add ] each ]
|
||||
} cleave ;
|
||||
|
||||
: <world> ( world-attributes -- world )
|
||||
[ world-class>> new-world ] keep apply-world-attributes
|
||||
dup request-focus ;
|
||||
|
||||
: as-big-as-possible ( world gadget -- )
|
||||
dup [ { 0 0 } >>loc over dim>> >>dim ] when 2drop ; inline
|
||||
|
|
@ -77,17 +95,36 @@ SYMBOL: flush-layout-cache-hook
|
|||
|
||||
flush-layout-cache-hook [ [ ] ] initialize
|
||||
|
||||
: (draw-world) ( world -- )
|
||||
dup handle>> [
|
||||
GENERIC: begin-world ( world -- )
|
||||
GENERIC: end-world ( world -- )
|
||||
|
||||
GENERIC: resize-world ( world -- )
|
||||
|
||||
M: world begin-world
|
||||
drop ;
|
||||
M: world end-world
|
||||
drop ;
|
||||
M: world resize-world
|
||||
drop ;
|
||||
|
||||
M: world (>>dim)
|
||||
[ call-next-method ]
|
||||
[
|
||||
dup handle>>
|
||||
[ select-gl-context resize-world ]
|
||||
[ drop ] if*
|
||||
] bi ;
|
||||
|
||||
GENERIC: draw-world* ( world -- )
|
||||
|
||||
M: world draw-world*
|
||||
check-extensions
|
||||
{
|
||||
[ init-gl ]
|
||||
[ draw-gadget ]
|
||||
[ text-handle>> [ purge-cache ] when* ]
|
||||
[ images>> [ purge-cache ] when* ]
|
||||
} cleave
|
||||
] with-gl-context
|
||||
flush-layout-cache-hook get call( -- ) ;
|
||||
} cleave ;
|
||||
|
||||
: draw-world? ( world -- ? )
|
||||
#! We don't draw deactivated worlds, or those with 0 size.
|
||||
|
|
@ -108,7 +145,10 @@ ui-error-hook [ [ rethrow ] ] initialize
|
|||
: draw-world ( world -- )
|
||||
dup draw-world? [
|
||||
dup world [
|
||||
[ (draw-world) ] [
|
||||
[
|
||||
dup handle>> [ draw-world* ] with-gl-context
|
||||
flush-layout-cache-hook get call( -- )
|
||||
] [
|
||||
over <world-error> ui-error
|
||||
f >>active? drop
|
||||
] recover
|
||||
|
|
@ -151,8 +191,7 @@ M: world handle-gesture ( gesture gadget -- ? )
|
|||
[ get-global find-world eq? ] keep '[ f _ set-global ] when ;
|
||||
|
||||
M: world world-pixel-format-attributes
|
||||
drop
|
||||
{ windowed double-buffered T{ depth-bits { value 16 } } } ;
|
||||
pixel-format-attributes>> ;
|
||||
|
||||
M: world check-world-pixel-format
|
||||
2drop ;
|
||||
|
|
@ -160,3 +199,4 @@ M: world check-world-pixel-format
|
|||
: with-world-pixel-format ( world quot -- )
|
||||
[ dup dup world-pixel-format-attributes <pixel-format> ]
|
||||
dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -91,29 +91,29 @@ HELP: backing-store
|
|||
{ double-buffered backing-store } related-words
|
||||
|
||||
HELP: multisampled
|
||||
{ $class-description "Requests a pixel format with multisampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be specified to specify the level of multisampling." }
|
||||
{ $class-description "Requests a pixel format with multisampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be provided to specify the level of multisampling." }
|
||||
{ $notes "On some window systems this is not distinct from " { $link supersampled } "." } ;
|
||||
|
||||
HELP: supersampled
|
||||
{ $class-description "Requests a pixel format with supersampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be specified to specify the level of supersampling." }
|
||||
{ $class-description "Requests a pixel format with supersampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be provided to specify the level of supersampling." }
|
||||
{ $notes "On some window systems this is not distinct from " { $link multisampled } "." } ;
|
||||
|
||||
HELP: sample-alpha
|
||||
{ $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request more accurate multisampling of alpha values." } ;
|
||||
|
||||
HELP: color-float
|
||||
{ $class-description "Requests a pixel format where the pixels are stored in floating-point format." } ;
|
||||
{ $class-description "Requests a pixel format where the color buffer is stored in floating-point format." } ;
|
||||
|
||||
HELP: color-bits
|
||||
{ $class-description "Requests a pixel format of at least " { $snippet "value" } " bits per pixel." } ;
|
||||
{ $class-description "Requests a pixel format with a color buffer of at least " { $snippet "value" } " bits per pixel." } ;
|
||||
HELP: red-bits
|
||||
{ $class-description "Requests a pixel format with at least " { $snippet "value" } " red bits per pixel." } ;
|
||||
{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " red bits per pixel." } ;
|
||||
HELP: green-bits
|
||||
{ $class-description "Requests a pixel format with at least " { $snippet "value" } " green bits per pixel." } ;
|
||||
{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " green bits per pixel." } ;
|
||||
HELP: blue-bits
|
||||
{ $class-description "Requests a pixel format with at least " { $snippet "value" } " blue bits per pixel." } ;
|
||||
{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " blue bits per pixel." } ;
|
||||
HELP: alpha-bits
|
||||
{ $class-description "Requests a pixel format with at least " { $snippet "value" } " alpha bits per pixel." } ;
|
||||
{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " alpha bits per pixel." } ;
|
||||
|
||||
{ color-float color-bits red-bits green-bits blue-bits alpha-bits } related-words
|
||||
|
||||
|
|
|
|||
|
|
@ -2,17 +2,28 @@ USING: help.markup help.syntax strings quotations debugger
|
|||
namespaces ui.backend ui.gadgets ui.gadgets.worlds
|
||||
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids
|
||||
ui.gadgets.private math.rectangles colors ui.text fonts
|
||||
kernel ui.private ;
|
||||
kernel ui.private classes sequences ;
|
||||
IN: ui
|
||||
|
||||
HELP: windows
|
||||
{ $var-description "Global variable holding an association list mapping native window handles to " { $link world } " instances." } ;
|
||||
|
||||
{ windows open-window find-window } related-words
|
||||
{ windows open-window find-window world-attributes } related-words
|
||||
|
||||
HELP: open-window
|
||||
{ $values { "gadget" gadget } { "title" string } }
|
||||
{ $description "Opens a native window with the specified title." } ;
|
||||
{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } }
|
||||
{ $description "Opens a native window containing " { $snippet "gadget" } " with the specified attributes. If a string is provided, it is used as the window title; otherwise, the window attributes are specified in a " { $link world-attributes } " tuple." } ;
|
||||
|
||||
HELP: world-attributes
|
||||
{ $values { "world-class" class } { "title" string } { "status" gadget } { "gadgets" sequence } { "pixel-format-attributes" sequence } }
|
||||
{ $class-description "Tuples of this class can be passed to " { $link open-window } " to control attributes of the window opened. The following attributes can be set:" }
|
||||
{ $list
|
||||
{ { $snippet "world-class" } " specifies the class of world to construct. " { $link world } " is the default." }
|
||||
{ { $snippet "title" } " is the window title." }
|
||||
{ { $snippet "status" } ", if specified, is a gadget that will be used as the window's status bar." }
|
||||
{ { $snippet "gadgets" } " is a sequence of gadgets that will be placed inside the window." }
|
||||
{ { $snippet "pixel-format-attributes" } " is a sequence of " { $link "ui.pixel-formats-attributes" } " that the window will request for its OpenGL pixel format." }
|
||||
} ;
|
||||
|
||||
HELP: set-fullscreen?
|
||||
{ $values { "?" "a boolean" } { "gadget" gadget } }
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@ USING: arrays assocs io kernel math models namespaces make dlists
|
|||
deques sequences threads sequences words continuations init
|
||||
combinators combinators.short-circuit hashtables concurrency.flags
|
||||
sets accessors calendar fry destructors ui.gadgets ui.gadgets.private
|
||||
ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render ;
|
||||
ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render
|
||||
strings ;
|
||||
IN: ui
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -49,8 +50,20 @@ SYMBOL: windows
|
|||
f >>focused?
|
||||
focus-path f swap focus-gestures ;
|
||||
|
||||
M: world graft*
|
||||
: try-to-open-window ( world -- )
|
||||
{
|
||||
[ (open-window) ]
|
||||
[ handle>> select-gl-context ]
|
||||
[
|
||||
[ begin-world ]
|
||||
[ [ handle>> (close-window) ] [ ui-error ] bi* ]
|
||||
recover
|
||||
]
|
||||
[ resize-world ]
|
||||
} cleave ;
|
||||
|
||||
M: world graft*
|
||||
[ try-to-open-window ]
|
||||
[ [ title>> ] keep set-title ]
|
||||
[ request-focus ] tri ;
|
||||
|
||||
|
|
@ -66,6 +79,7 @@ M: world graft*
|
|||
[ images>> [ dispose ] when* ]
|
||||
[ hand-clicked close-global ]
|
||||
[ hand-gadget close-global ]
|
||||
[ end-world ]
|
||||
} cleave ;
|
||||
|
||||
M: world ungraft*
|
||||
|
|
@ -166,13 +180,17 @@ PRIVATE>
|
|||
: restore-windows? ( -- ? )
|
||||
windows get empty? not ;
|
||||
|
||||
: ?attributes ( gadget title/attributes -- attributes )
|
||||
dup string? [ world-attributes new swap >>title ] when
|
||||
swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: open-world-window ( world -- )
|
||||
dup pref-dim >>dim dup relayout graft ;
|
||||
|
||||
: open-window ( gadget title -- )
|
||||
f <world> open-world-window ;
|
||||
: open-window ( gadget title/attributes -- )
|
||||
?attributes <world> open-world-window ;
|
||||
|
||||
: set-fullscreen? ( ? gadget -- )
|
||||
find-world set-fullscreen* ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: alien.c-types kernel locals math math.bitwise
|
||||
windows.kernel32 sequences byte-arrays unicode.categories
|
||||
io.encodings.string io.encodings.utf16n alien.strings
|
||||
arrays ;
|
||||
arrays literals ;
|
||||
IN: windows.errors
|
||||
|
||||
CONSTANT: ERROR_SUCCESS 0
|
||||
|
|
@ -732,11 +732,13 @@ ERROR: error-message-failed id ;
|
|||
win32-error-string throw
|
||||
] when ;
|
||||
|
||||
: expected-io-errors ( -- seq )
|
||||
CONSTANT: expected-io-errors
|
||||
${
|
||||
ERROR_SUCCESS
|
||||
ERROR_IO_INCOMPLETE
|
||||
ERROR_IO_PENDING
|
||||
WAIT_TIMEOUT 4array ; foldable
|
||||
WAIT_TIMEOUT
|
||||
}
|
||||
|
||||
: expected-io-error? ( error-code -- ? )
|
||||
expected-io-errors member? ;
|
||||
|
|
|
|||
|
|
@ -1,58 +1,67 @@
|
|||
USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline
|
||||
bunny.model bunny.outlined destructors kernel math opengl.demo-support
|
||||
opengl.gl sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
|
||||
ui.render words ;
|
||||
ui.render words ui.pixel-formats ;
|
||||
IN: bunny
|
||||
|
||||
TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ;
|
||||
TUPLE: bunny-world < demo-world model-triangles geom draw-seq draw-n ;
|
||||
|
||||
: <bunny-gadget> ( -- bunny-gadget )
|
||||
0.0 0.0 0.375 bunny-gadget new-demo-gadget
|
||||
maybe-download read-model >>model-triangles ;
|
||||
|
||||
: bunny-gadget-draw ( gadget -- draw )
|
||||
: get-draw ( gadget -- draw )
|
||||
[ draw-n>> ] [ draw-seq>> ] bi nth ;
|
||||
|
||||
: bunny-gadget-next-draw ( gadget -- )
|
||||
: next-draw ( gadget -- )
|
||||
dup [ draw-seq>> ] [ draw-n>> ] bi
|
||||
1+ swap length mod
|
||||
>>draw-n relayout-1 ;
|
||||
|
||||
M: bunny-gadget graft* ( gadget -- )
|
||||
dup find-gl-context
|
||||
GL_DEPTH_TEST glEnable
|
||||
dup model-triangles>> <bunny-geom> >>geom
|
||||
dup
|
||||
: make-draws ( gadget -- draw-seq )
|
||||
[ <bunny-fixed-pipeline> ]
|
||||
[ <bunny-cel-shaded> ]
|
||||
[ <bunny-outlined> ] tri 3array
|
||||
sift >>draw-seq
|
||||
sift ;
|
||||
|
||||
M: bunny-world begin-world
|
||||
GL_DEPTH_TEST glEnable
|
||||
0.0 0.0 0.375 set-demo-orientation
|
||||
maybe-download read-model
|
||||
[ >>model-triangles ] [ <bunny-geom> >>geom ] bi
|
||||
dup make-draws >>draw-seq
|
||||
0 >>draw-n
|
||||
drop ;
|
||||
|
||||
M: bunny-gadget ungraft* ( gadget -- )
|
||||
M: bunny-world end-world
|
||||
dup find-gl-context
|
||||
[ geom>> [ dispose ] when* ]
|
||||
[ draw-seq>> [ [ dispose ] when* ] each ] bi ;
|
||||
|
||||
M: bunny-gadget draw-gadget* ( gadget -- )
|
||||
M: bunny-world draw-world*
|
||||
dup draw-seq>> empty? [ drop ] [
|
||||
0.15 0.15 0.15 1.0 glClearColor
|
||||
GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
|
||||
dup demo-gadget-set-matrices
|
||||
dup demo-world-set-matrix
|
||||
GL_MODELVIEW glMatrixMode
|
||||
0.02 -0.105 0.0 glTranslatef
|
||||
[ geom>> ] [ bunny-gadget-draw ] bi draw-bunny
|
||||
[ geom>> ] [ get-draw ] bi draw-bunny
|
||||
] if ;
|
||||
|
||||
M: bunny-gadget pref-dim* ( gadget -- dim )
|
||||
M: bunny-world pref-dim* ( gadget -- dim )
|
||||
drop { 640 480 } ;
|
||||
|
||||
bunny-gadget H{
|
||||
{ T{ key-down f f "TAB" } [ bunny-gadget-next-draw ] }
|
||||
bunny-world H{
|
||||
{ T{ key-down f f "TAB" } [ next-draw ] }
|
||||
} set-gestures
|
||||
|
||||
: bunny-window ( -- )
|
||||
[ <bunny-gadget> "Bunny" open-window ] with-ui ;
|
||||
[
|
||||
f T{ world-attributes
|
||||
{ world-class bunny-world }
|
||||
{ title "Bunny" }
|
||||
{ pixel-format-attributes {
|
||||
windowed
|
||||
double-buffered
|
||||
T{ depth-bits { value 16 } }
|
||||
} }
|
||||
} open-window
|
||||
] with-ui ;
|
||||
|
||||
MAIN: bunny-window
|
||||
|
|
|
|||
|
|
@ -216,7 +216,11 @@ MACRO: (framebuffer-texture>>draw) ( iformat xformat setter -- )
|
|||
] with-framebuffer ;
|
||||
|
||||
: (pass2) ( draw -- )
|
||||
init-matrices {
|
||||
GL_PROJECTION glMatrixMode
|
||||
glPushMatrix glLoadIdentity
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity
|
||||
{
|
||||
[ color-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
|
||||
[ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ]
|
||||
[ depth-texture>> GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ]
|
||||
|
|
@ -230,7 +234,9 @@ MACRO: (framebuffer-texture>>draw) ( iformat xformat setter -- )
|
|||
} cleave { -1.0 -1.0 } { 1.0 1.0 } rect-vertices
|
||||
] with-gl-program
|
||||
]
|
||||
} cleave ;
|
||||
} cleave
|
||||
GL_PROJECTION glMatrixMode
|
||||
glPopMatrix ;
|
||||
|
||||
M: bunny-outlined draw-bunny
|
||||
[ remake-framebuffer-if-needed ]
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
USING: accessors delegate delegate.protocols io.pathnames
|
||||
kernel locals namespaces sequences vectors
|
||||
tools.annotations prettyprint ;
|
||||
USING: accessors arrays delegate delegate.protocols
|
||||
io.pathnames kernel locals namespaces prettyprint sequences
|
||||
ui.frp vectors ;
|
||||
IN: file-trees
|
||||
|
||||
TUPLE: tree node children ;
|
||||
CONSULT: sequence-protocol tree children>> [ node>> ] map ;
|
||||
CONSULT: sequence-protocol tree children>> ;
|
||||
|
||||
: <tree> ( start -- tree ) V{ } clone
|
||||
[ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ;
|
||||
|
|
@ -21,3 +21,8 @@ DEFER: (tree-insert)
|
|||
] if* ;
|
||||
: create-tree ( file-list -- tree ) [ path-components ] map
|
||||
t <tree> [ [ tree-insert ] curry each ] keep ;
|
||||
|
||||
: <dir-table> ( tree-model -- table )
|
||||
<frp-list*> [ node>> 1array ] >>quot
|
||||
[ selected-value>> <switch> ]
|
||||
[ swap >>model ] bi ;
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
USING: arrays kernel math math.functions math.order math.vectors
|
||||
namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures
|
||||
ui.render accessors combinators ;
|
||||
ui.gadgets.worlds ui.render accessors combinators ;
|
||||
IN: opengl.demo-support
|
||||
|
||||
: FOV ( -- x ) 2.0 sqrt 1+ ; inline
|
||||
|
|
@ -9,62 +9,62 @@ CONSTANT: KEY-ROTATE-STEP 10.0
|
|||
|
||||
SYMBOL: last-drag-loc
|
||||
|
||||
TUPLE: demo-gadget < gadget yaw pitch distance ;
|
||||
TUPLE: demo-world < world yaw pitch distance ;
|
||||
|
||||
: new-demo-gadget ( yaw pitch distance class -- gadget )
|
||||
new
|
||||
swap >>distance
|
||||
swap >>pitch
|
||||
swap >>yaw ; inline
|
||||
: set-demo-orientation ( world yaw pitch distance -- world )
|
||||
[ >>yaw ] [ >>pitch ] [ >>distance ] tri* ;
|
||||
|
||||
GENERIC: far-plane ( gadget -- z )
|
||||
GENERIC: near-plane ( gadget -- z )
|
||||
GENERIC: distance-step ( gadget -- dz )
|
||||
|
||||
M: demo-gadget far-plane ( gadget -- z )
|
||||
M: demo-world far-plane ( gadget -- z )
|
||||
drop 4.0 ;
|
||||
M: demo-gadget near-plane ( gadget -- z )
|
||||
M: demo-world near-plane ( gadget -- z )
|
||||
drop 1.0 64.0 / ;
|
||||
M: demo-gadget distance-step ( gadget -- dz )
|
||||
M: demo-world distance-step ( gadget -- dz )
|
||||
drop 1.0 64.0 / ;
|
||||
|
||||
: fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ;
|
||||
|
||||
: yaw-demo-gadget ( yaw gadget -- )
|
||||
: yaw-demo-world ( yaw gadget -- )
|
||||
[ + ] with change-yaw relayout-1 ;
|
||||
|
||||
: pitch-demo-gadget ( pitch gadget -- )
|
||||
: pitch-demo-world ( pitch gadget -- )
|
||||
[ + ] with change-pitch relayout-1 ;
|
||||
|
||||
: zoom-demo-gadget ( distance gadget -- )
|
||||
: zoom-demo-world ( distance gadget -- )
|
||||
[ + ] with change-distance relayout-1 ;
|
||||
|
||||
M: demo-gadget pref-dim* ( gadget -- dim )
|
||||
M: demo-world focusable-child* ( world -- gadget )
|
||||
drop t ;
|
||||
|
||||
M: demo-world pref-dim* ( gadget -- dim )
|
||||
drop { 640 480 } ;
|
||||
|
||||
: -+ ( x -- -x x )
|
||||
[ neg ] keep ;
|
||||
|
||||
: demo-gadget-frustum ( gadget -- -x x -y y near far )
|
||||
: demo-world-frustum ( world -- -x x -y y near far )
|
||||
[ near-plane ] [ far-plane ] [ fov-ratio ] tri [
|
||||
nip swap FOV / v*n
|
||||
first2 [ -+ ] bi@
|
||||
] 3keep drop ;
|
||||
|
||||
: demo-gadget-set-matrices ( gadget -- )
|
||||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
|
||||
[
|
||||
M: demo-world resize-world
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
demo-gadget-frustum glFrustum
|
||||
] [
|
||||
[ [ 0 0 ] dip dim>> first2 glViewport ]
|
||||
[ demo-world-frustum glFrustum ] bi ;
|
||||
|
||||
: demo-world-set-matrix ( gadget -- )
|
||||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity
|
||||
[ [ 0.0 0.0 ] dip distance>> neg glTranslatef ]
|
||||
[ pitch>> 1.0 0.0 0.0 glRotatef ]
|
||||
[ yaw>> 0.0 1.0 0.0 glRotatef ]
|
||||
tri
|
||||
] bi ;
|
||||
tri ;
|
||||
|
||||
: reset-last-drag-rel ( -- )
|
||||
{ 0 0 } last-drag-loc set-global ;
|
||||
|
|
@ -94,16 +94,16 @@ M: demo-gadget pref-dim* ( gadget -- dim )
|
|||
swap first swap second glVertex2d
|
||||
] do-state ;
|
||||
|
||||
demo-gadget H{
|
||||
{ T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-demo-gadget ] }
|
||||
{ T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-gadget ] }
|
||||
{ T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-gadget ] }
|
||||
{ T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-gadget ] }
|
||||
{ T{ key-down f f "=" } [ dup distance-step neg swap zoom-demo-gadget ] }
|
||||
{ T{ key-down f f "-" } [ dup distance-step swap zoom-demo-gadget ] }
|
||||
demo-world H{
|
||||
{ T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-demo-world ] }
|
||||
{ T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-world ] }
|
||||
{ T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-world ] }
|
||||
{ T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-world ] }
|
||||
{ T{ key-down f f "=" } [ dup distance-step neg swap zoom-demo-world ] }
|
||||
{ T{ key-down f f "-" } [ dup distance-step swap zoom-demo-world ] }
|
||||
|
||||
{ T{ button-down f f 1 } [ drop reset-last-drag-rel ] }
|
||||
{ T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] }
|
||||
{ mouse-scroll [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] }
|
||||
{ T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-world ] keep yaw-demo-world ] }
|
||||
{ mouse-scroll [ scroll-direction get second over distance-step * swap zoom-demo-world ] }
|
||||
} set-gestures
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
USING: kernel opengl opengl.demo-support opengl.gl opengl.textures
|
||||
opengl.shaders opengl.framebuffers opengl.capabilities multiline
|
||||
ui.gadgets accessors sequences ui.render ui math locals arrays
|
||||
generalizations combinators ui.gadgets.worlds ;
|
||||
generalizations combinators ui.gadgets.worlds
|
||||
literals ui.pixel-formats ;
|
||||
IN: spheres
|
||||
|
||||
STRING: plane-vertex-shader
|
||||
|
|
@ -110,19 +111,16 @@ main()
|
|||
}
|
||||
;
|
||||
|
||||
TUPLE: spheres-gadget < demo-gadget
|
||||
TUPLE: spheres-world < demo-world
|
||||
plane-program solid-sphere-program texture-sphere-program
|
||||
reflection-framebuffer reflection-depthbuffer
|
||||
reflection-texture initialized? ;
|
||||
reflection-texture ;
|
||||
|
||||
: <spheres-gadget> ( -- gadget )
|
||||
20.0 10.0 20.0 spheres-gadget new-demo-gadget ;
|
||||
|
||||
M: spheres-gadget near-plane ( gadget -- z )
|
||||
M: spheres-world near-plane ( gadget -- z )
|
||||
drop 1.0 ;
|
||||
M: spheres-gadget far-plane ( gadget -- z )
|
||||
M: spheres-world far-plane ( gadget -- z )
|
||||
drop 512.0 ;
|
||||
M: spheres-gadget distance-step ( gadget -- dz )
|
||||
M: spheres-world distance-step ( gadget -- dz )
|
||||
drop 0.5 ;
|
||||
|
||||
: (reflection-dim) ( -- w h )
|
||||
|
|
@ -136,12 +134,14 @@ M: spheres-gadget distance-step ( gadget -- dz )
|
|||
GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
|
||||
GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri
|
||||
GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R GL_CLAMP glTexParameteri
|
||||
${
|
||||
GL_TEXTURE_CUBE_MAP_POSITIVE_X
|
||||
GL_TEXTURE_CUBE_MAP_POSITIVE_Y
|
||||
GL_TEXTURE_CUBE_MAP_POSITIVE_Z
|
||||
GL_TEXTURE_CUBE_MAP_NEGATIVE_X
|
||||
GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
|
||||
GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 6 narray
|
||||
GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
|
||||
}
|
||||
[ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ]
|
||||
each
|
||||
] keep ;
|
||||
|
|
@ -171,22 +171,19 @@ M: spheres-gadget distance-step ( gadget -- dz )
|
|||
sphere-main-fragment-shader <fragment-shader> check-gl-shader
|
||||
3array <gl-program> check-gl-program ;
|
||||
|
||||
M: spheres-gadget graft* ( gadget -- )
|
||||
dup find-gl-context
|
||||
M: spheres-world begin-world
|
||||
"2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions
|
||||
{ "GL_EXT_framebuffer_object" } require-gl-extensions
|
||||
20.0 10.0 20.0 set-demo-orientation
|
||||
(plane-program) >>plane-program
|
||||
(solid-sphere-program) >>solid-sphere-program
|
||||
(texture-sphere-program) >>texture-sphere-program
|
||||
(make-reflection-texture) >>reflection-texture
|
||||
(make-reflection-depthbuffer) [ >>reflection-depthbuffer ] keep
|
||||
(make-reflection-framebuffer) >>reflection-framebuffer
|
||||
t >>initialized?
|
||||
drop ;
|
||||
|
||||
M: spheres-gadget ungraft* ( gadget -- )
|
||||
f >>initialized?
|
||||
dup find-gl-context
|
||||
M: spheres-world end-world
|
||||
{
|
||||
[ reflection-framebuffer>> [ delete-framebuffer ] when* ]
|
||||
[ reflection-depthbuffer>> [ delete-renderbuffer ] when* ]
|
||||
|
|
@ -196,7 +193,7 @@ M: spheres-gadget ungraft* ( gadget -- )
|
|||
[ plane-program>> [ delete-gl-program ] when* ]
|
||||
} cleave ;
|
||||
|
||||
M: spheres-gadget pref-dim* ( gadget -- dim )
|
||||
M: spheres-world pref-dim* ( gadget -- dim )
|
||||
drop { 640 480 } ;
|
||||
|
||||
:: (draw-sphere) ( program center radius -- )
|
||||
|
|
@ -254,7 +251,7 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
|
|||
[ drop 0 0 (reflection-dim) glViewport ]
|
||||
[
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
glPushMatrix glLoadIdentity
|
||||
reflection-frustum glFrustum
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity
|
||||
|
|
@ -277,15 +274,19 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
|
|||
[ GL_TEXTURE_CUBE_MAP_POSITIVE_Y (reflection-face)
|
||||
glPopMatrix 90.0 1.0 0.0 0.0 glRotatef ]
|
||||
[ sphere-scene ]
|
||||
[ dim>> 0 0 rot first2 glViewport ]
|
||||
[
|
||||
[ 0 0 ] dip dim>> first2 glViewport
|
||||
GL_PROJECTION glMatrixMode
|
||||
glPopMatrix
|
||||
]
|
||||
} cleave ] with-framebuffer ;
|
||||
|
||||
: (draw-gadget) ( gadget -- )
|
||||
M: spheres-world draw-world*
|
||||
GL_DEPTH_TEST glEnable
|
||||
GL_SCISSOR_TEST glDisable
|
||||
0.15 0.15 1.0 1.0 glClearColor {
|
||||
[ (draw-reflection-texture) ]
|
||||
[ demo-gadget-set-matrices ]
|
||||
[ demo-world-set-matrix ]
|
||||
[ sphere-scene ]
|
||||
[ reflection-texture>> GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit ]
|
||||
[
|
||||
|
|
@ -297,10 +298,17 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
|
|||
]
|
||||
} cleave ;
|
||||
|
||||
M: spheres-gadget draw-gadget* ( gadget -- )
|
||||
dup initialized?>> [ (draw-gadget) ] [ drop ] if ;
|
||||
|
||||
: spheres-window ( -- )
|
||||
[ <spheres-gadget> "Spheres" open-window ] with-ui ;
|
||||
[
|
||||
f T{ world-attributes
|
||||
{ world-class spheres-world }
|
||||
{ title "Spheres" }
|
||||
{ pixel-format-attributes {
|
||||
windowed
|
||||
double-buffered
|
||||
T{ depth-bits { value 16 } }
|
||||
} }
|
||||
} open-window
|
||||
] with-ui ;
|
||||
|
||||
MAIN: spheres-window
|
||||
|
|
|
|||
|
|
@ -1,4 +1,7 @@
|
|||
USING: kernel sequences splitting strings.parser ;
|
||||
USING: combinators effects kernel math sequences splitting
|
||||
strings.parser ;
|
||||
IN: str-fry
|
||||
: str-fry ( str -- quot ) "_" split unclip [ [ rot glue ] reduce ] 2curry ;
|
||||
: str-fry ( str -- quot ) "_" split
|
||||
[ unclip [ [ rot glue ] reduce ] 2curry ]
|
||||
[ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
|
||||
SYNTAX: I" parse-string rest str-fry over push-all ;
|
||||
|
|
@ -36,7 +36,7 @@ HELP: <fold>
|
|||
{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } }
|
||||
{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
|
||||
|
||||
HELP: switch
|
||||
HELP: <switch>
|
||||
{ $values { "signal1" model } { "signal2" model } { "signal'" model } }
|
||||
{ $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: accessors arrays colors fonts fry kernel models
|
||||
USING: accessors arrays colors fonts kernel models
|
||||
models.product monads sequences ui.gadgets ui.gadgets.buttons
|
||||
ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables
|
||||
ui.gadgets.tracks ui.render ;
|
||||
ui.gadgets.tracks ui.render ui.gadgets.scrollers ;
|
||||
QUALIFIED: make
|
||||
IN: ui.frp
|
||||
|
||||
|
|
@ -18,8 +18,11 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
|
|||
frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model
|
||||
f <model> >>selected-value sans-serif-font >>font
|
||||
focus-border-color >>focus-border-color
|
||||
transparent >>column-line-color ;
|
||||
transparent >>column-line-color [ ] >>val-quot ;
|
||||
: <frp-table*> ( -- table ) f <model> <frp-table> ;
|
||||
: <frp-list> ( model -- table ) <frp-table> [ 1array ] >>quot ;
|
||||
: <frp-list*> ( -- table ) f <model> <frp-list> ;
|
||||
|
||||
: <frp-field> ( -- field ) f <model> <model-field> ;
|
||||
|
||||
! Layout utilities
|
||||
|
|
@ -27,6 +30,8 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
|
|||
GENERIC: output-model ( gadget -- model )
|
||||
M: gadget output-model model>> ;
|
||||
M: frp-table output-model selected-value>> ;
|
||||
M: model-field output-model field-model>> ;
|
||||
M: scroller output-model children>> first model>> ;
|
||||
|
||||
GENERIC: , ( uiitem -- )
|
||||
M: gadget , make:, ;
|
||||
|
|
@ -41,13 +46,16 @@ M: table -> dup , selected-value>> ;
|
|||
[ { } make:make ] dip <track> swap [ f track-add ] each ; inline
|
||||
: <box*> ( gadgets type -- track ) [ <box> ] [ [ model>> ] map <product> ] bi >>model ; inline
|
||||
: <hbox> ( gadgets -- track ) horizontal <box> ; inline
|
||||
: <hbox*> ( gadgets -- track ) horizontal <box*> ; inline
|
||||
: <vbox> ( gadgets -- track ) vertical <box> ; inline
|
||||
: <vbox*> ( gadgets -- track ) vertical <box*> ; inline
|
||||
|
||||
! Model utilities
|
||||
! !!! Model utilities
|
||||
TUPLE: multi-model < model ;
|
||||
! M: multi-model model-activated dup model-changed ;
|
||||
: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
|
||||
|
||||
! Events- discrete model utilities
|
||||
|
||||
TUPLE: merge-model < multi-model ;
|
||||
M: merge-model model-changed [ value>> ] dip set-model ;
|
||||
: <merge> ( models -- model ) merge-model <multi-model> ;
|
||||
|
|
@ -57,15 +65,21 @@ M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2ke
|
|||
[ set-model ] [ 2drop ] if ;
|
||||
: <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-model> ] dip >>quot ;
|
||||
|
||||
! Behaviors - continuous model utilities
|
||||
|
||||
TUPLE: fold-model < multi-model oldval quot ;
|
||||
M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi*
|
||||
call( val oldval -- newval ) ] keep set-model ;
|
||||
: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot swap >>oldval ;
|
||||
: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot
|
||||
swap [ >>oldval ] [ >>value ] bi ;
|
||||
|
||||
TUPLE: switch-model < multi-model switcher on ;
|
||||
M: switch-model model-changed tuck [ switcher>> = ] 2keep
|
||||
'[ on>> [ _ value>> _ set-model ] when ] [ t swap (>>on) ] if ;
|
||||
: switch ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] keep >>switcher ;
|
||||
TUPLE: switch-model < multi-model original switcher on ;
|
||||
M: switch-model model-changed 2dup switcher>> =
|
||||
[ over value>> [ [ value>> ] [ t >>on ] bi* set-model ] [ 2drop ] if ]
|
||||
[ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ;
|
||||
M: switch-model model-activated [ original>> ] keep model-changed ;
|
||||
: <switch> ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] 2keep
|
||||
[ >>original ] [ >>switcher ] bi* ;
|
||||
|
||||
TUPLE: mapped < model model quot ;
|
||||
|
||||
|
|
@ -87,4 +101,4 @@ INSTANCE: gadget-monad monad
|
|||
INSTANCE: gadget monad
|
||||
M: gadget monad-of drop gadget-monad ;
|
||||
M: gadget-monad return drop <gadget> swap >>model ;
|
||||
M: gadget >>= model>> '[ _ swap call( x -- y ) ] ;
|
||||
M: gadget >>= output-model [ swap call( x -- y ) ] curry ;
|
||||
Loading…
Reference in New Issue