diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index ac0b0850b4..5a517e4ac4 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -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 - 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 ] - [ month>> month-abbreviation ] - [ day>> pad-00 ] - [ >time ] - [ year>> number>string ] - } cleave 5 narray " " join ; inline + [ + { + [ day-of-week day-abbreviation3 ] + [ month>> month-abbreviation ] + [ day>> pad-00 ] + [ >time ] + [ year>> number>string ] + } 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 '[ _ @ reverse concat nip ] ; - - diff --git a/basis/literals/literals-tests.factor b/basis/literals/literals-tests.factor index 024c94e4f2..29072f1299 100644 --- a/basis/literals/literals-tests.factor +++ b/basis/literals/literals-tests.factor @@ -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 diff --git a/basis/literals/literals.factor b/basis/literals/literals.factor index e55d78ab6e..7c7592dda8 100644 --- a/basis/literals/literals.factor +++ b/basis/literals/literals.factor @@ -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 ; diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 1976c84fd1..22dec9d2fc 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -135,8 +135,8 @@ M: pathname pprint* [ text ] [ f ] bi* \ } pprint-word block> ; -M: tuple pprint* - boa-tuples? get [ call-next-method ] [ +: pprint-tuple ( tuple -- ) + boa-tuples? get [ pprint-object ] [ [ Factor UI button mapping diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 32d6c0c8a6..f9f397d46f 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -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>> ; diff --git a/basis/ui/gadgets/status-bar/status-bar-docs.factor b/basis/ui/gadgets/status-bar/status-bar-docs.factor index 57c69c2a66..7a68310e36 100644 --- a/basis/ui/gadgets/status-bar/status-bar-docs.factor +++ b/basis/ui/gadgets/status-bar/status-bar-docs.factor @@ -18,7 +18,7 @@ HELP: { $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 } ; @@ -30,4 +30,4 @@ ARTICLE: "ui.gadgets.status-bar" "Status bars and mouse-over help" { $subsection hide-status } { $link "ui.gadgets.presentations" } " use the status bar to display object summary." ; -ABOUT: "ui.gadgets.status-bar" \ No newline at end of file +ABOUT: "ui.gadgets.status-bar" diff --git a/basis/ui/gadgets/status-bar/status-bar.factor b/basis/ui/gadgets/status-bar/status-bar.factor index a1c2dca23d..0d3015508e 100644 --- a/basis/ui/gadgets/status-bar/status-bar.factor +++ b/basis/ui/gadgets/status-bar/status-bar.factor @@ -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 : ( model -- gadget ) @@ -10,9 +10,9 @@ IN: ui.gadgets.status-bar reverse-video-theme t >>root? ; -: open-status-window ( gadget title -- ) - f [ ] keep - f track-add +: open-status-window ( gadget title/attributes -- ) + ?attributes f >>status + dup status>> f track-add open-world-window ; : show-summary ( object gadget -- ) diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor index 9d4df189f2..d4e9790d89 100755 --- a/basis/ui/gadgets/worlds/worlds-docs.factor +++ b/basis/ui/gadgets/worlds/worlds-docs.factor @@ -48,8 +48,8 @@ HELP: world } ; HELP: -{ $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" } ; diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 171272dfc1..31b5a137a3 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -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 : 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 ; -: ( 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-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>> [ - 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( -- ) ; +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 ; : 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 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 ] dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline + diff --git a/basis/ui/pixel-formats/pixel-formats-docs.factor b/basis/ui/pixel-formats/pixel-formats-docs.factor index 207b757908..003b205c3d 100644 --- a/basis/ui/pixel-formats/pixel-formats-docs.factor +++ b/basis/ui/pixel-formats/pixel-formats-docs.factor @@ -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 diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index f2b6154745..397fc419fa 100644 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -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 } } diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 09403cb2d2..d07403836a 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -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 >focused? focus-path f swap focus-gestures ; +: 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* - [ (open-window) ] + [ 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 open-world-window ; +: open-window ( gadget title/attributes -- ) + ?attributes open-world-window ; : set-fullscreen? ( ? gadget -- ) find-world set-fullscreen* ; diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index e08704d469..d180cb20e7 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -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 ) - ERROR_SUCCESS - ERROR_IO_INCOMPLETE - ERROR_IO_PENDING - WAIT_TIMEOUT 4array ; foldable +CONSTANT: expected-io-errors + ${ + ERROR_SUCCESS + ERROR_IO_INCOMPLETE + ERROR_IO_PENDING + WAIT_TIMEOUT + } : expected-io-error? ( error-code -- ? ) expected-io-errors member? ; diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index d0625e464f..620f737fe3 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -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 ) - 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>> >>geom - dup +: make-draws ( gadget -- draw-seq ) [ ] [ ] [ ] 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 ] [ >>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" 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 diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 7491ed8bcb..0ad2a72100 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -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 ] diff --git a/extra/file-trees/file-trees.factor b/extra/file-trees/file-trees.factor index 788291c0a2..eadfccdc4c 100644 --- a/extra/file-trees/file-trees.factor +++ b/extra/file-trees/file-trees.factor @@ -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>> ; : ( start -- tree ) V{ } clone [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ; @@ -20,4 +20,9 @@ DEFER: (tree-insert) path-rest [ path-head tree-insert ] unless-empty ] if* ; : create-tree ( file-list -- tree ) [ path-components ] map - t [ [ tree-insert ] curry each ] keep ; \ No newline at end of file + t [ [ tree-insert ] curry each ] keep ; + +: ( tree-model -- table ) + [ node>> 1array ] >>quot + [ selected-value>> ] + [ swap >>model ] bi ; \ No newline at end of file diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 5973766c8e..35c64d4ad1 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -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 -- ) +M: demo-world resize-world + GL_PROJECTION glMatrixMode + glLoadIdentity + [ [ 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_PROJECTION glMatrixMode - glLoadIdentity - demo-gadget-frustum glFrustum - ] [ - 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 ; + 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 ; : 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 diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index fa666dd776..710c953ed1 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -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 ; -: ( -- 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_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 + } [ 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 check-gl-shader 3array 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" 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 diff --git a/extra/str-fry/str-fry.factor b/extra/str-fry/str-fry.factor index aafdaa95d9..bfe74f37eb 100644 --- a/extra/str-fry/str-fry.factor +++ b/extra/str-fry/str-fry.factor @@ -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 [ call-effect ] 2curry ] bi ; SYNTAX: I" parse-string rest str-fry over push-all ; \ No newline at end of file diff --git a/extra/ui/frp/frp-docs.factor b/extra/ui/frp/frp-docs.factor index af44567e46..479a56e513 100644 --- a/extra/ui/frp/frp-docs.factor +++ b/extra/ui/frp/frp-docs.factor @@ -36,7 +36,7 @@ HELP: { $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: { $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" } ; diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor index aa7c44ee03..699d034c72 100644 --- a/extra/ui/frp/frp.factor +++ b/extra/ui/frp/frp.factor @@ -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 >>selected-value sans-serif-font >>font focus-border-color >>focus-border-color - transparent >>column-line-color ; + transparent >>column-line-color [ ] >>val-quot ; +: ( -- table ) f ; : ( model -- table ) [ 1array ] >>quot ; +: ( -- table ) f ; + : ( -- field ) f ; ! 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 swap [ f track-add ] each ; inline : ( gadgets type -- track ) [ ] [ [ model>> ] map ] bi >>model ; inline : ( gadgets -- track ) horizontal ; inline +: ( gadgets -- track ) horizontal ; inline : ( gadgets -- track ) vertical ; inline +: ( gadgets -- track ) vertical ; inline -! Model utilities +! !!! Model utilities TUPLE: multi-model < model ; -! M: multi-model model-activated dup model-changed ; : ( 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 ; : ( models -- model ) merge-model ; @@ -57,15 +65,21 @@ M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2ke [ set-model ] [ 2drop ] if ; : ( model quot -- filter-model ) [ 1array filter-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 ; -: ( oldval quot model -- model' ) 1array fold-model swap >>quot swap >>oldval ; +: ( oldval quot model -- model' ) 1array fold-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 ] 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 ; +: ( signal1 signal2 -- signal' ) [ 2array switch-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 swap >>model ; -M: gadget >>= model>> '[ _ swap call( x -- y ) ] ; \ No newline at end of file +M: gadget >>= output-model [ swap call( x -- y ) ] curry ; \ No newline at end of file diff --git a/extra/ui/offscreen/authors.txt b/unmaintained/ui/offscreen/authors.txt similarity index 100% rename from extra/ui/offscreen/authors.txt rename to unmaintained/ui/offscreen/authors.txt diff --git a/extra/ui/offscreen/offscreen-docs.factor b/unmaintained/ui/offscreen/offscreen-docs.factor similarity index 100% rename from extra/ui/offscreen/offscreen-docs.factor rename to unmaintained/ui/offscreen/offscreen-docs.factor diff --git a/extra/ui/offscreen/offscreen.factor b/unmaintained/ui/offscreen/offscreen.factor similarity index 100% rename from extra/ui/offscreen/offscreen.factor rename to unmaintained/ui/offscreen/offscreen.factor diff --git a/extra/ui/offscreen/summary.txt b/unmaintained/ui/offscreen/summary.txt similarity index 100% rename from extra/ui/offscreen/summary.txt rename to unmaintained/ui/offscreen/summary.txt diff --git a/extra/ui/offscreen/tags.txt b/unmaintained/ui/offscreen/tags.txt similarity index 100% rename from extra/ui/offscreen/tags.txt rename to unmaintained/ui/offscreen/tags.txt