-USING: accessors alien.c-types alien.data alien.data.map arrays\r
-assocs byte-arrays colors combinators combinators.short-circuit\r
-destructors euler.b-rep euler.b-rep.triangulation fry game.input\r
-game.loop game.models.half-edge game.worlds gml.printer gpu\r
-gpu.buffers gpu.framebuffers gpu.render gpu.shaders gpu.state\r
-gpu.util.wasd growable images kernel literals locals math\r
-math.order math.ranges math.vectors math.vectors.conversion\r
-math.vectors.simd math.vectors.simd.cords method-chains models\r
-namespaces sequences sets specialized-vectors typed ui\r
-ui.gadgets ui.gadgets.worlds ui.gestures ui.pixel-formats\r
-vectors ;\r
-FROM: math.matrices => m.v ;\r
-FROM: models => change-model ;\r
-SPECIALIZED-VECTORS: ushort float-4 ;\r
-IN: gml.viewer\r
-\r
-CONSTANT: neutral-edge-color float-4{ 1 1 1 1 }\r
-CONSTANT: neutral-face-color float-4{ 1 1 1 1 }\r
-CONSTANT: selected-face-color float-4{ 1 0.9 0.8 1 }\r
-\r
-: double-4>float-4 ( in: double-4 -- out: float-4 )\r
- [ head>> ] [ tail>> ] bi double-2 float-4 vconvert ; inline\r
-: rgba>float-4 ( in: rgba -- out: float-4 )\r
- >rgba-components float-4-boa ; inline\r
-\r
-: face-color ( edge -- color )\r
- face-normal float-4{ 0 1 0.1 0 } v. 0.3 * 0.4 + dup dup 1.0 float-4-boa ; inline\r
-\r
-TUPLE: b-rep-vertices\r
- { array byte-array read-only }\r
- { face-vertex-count integer read-only }\r
- { edge-vertex-count integer read-only }\r
- { point-vertex-count integer read-only } ;\r
-\r
-:: <b-rep-vertices> ( face-array face-count\r
- edge-array edge-count\r
- point-array point-count -- vxs )\r
- face-array edge-array point-array 3append\r
- face-count edge-count point-count \ b-rep-vertices boa ; inline\r
-\r
-: face-selected? ( face selected -- ? )\r
- [ f ] 2dip [ edge>> ] dip '[ _ in? or ] each-face-edge ;\r
-\r
-:: b-rep-face-vertices ( b-rep selected -- vertices count indices )\r
- float-4-vector{ } clone :> vertices\r
- ushort-vector{ } clone :> indices\r
-\r
- 0 b-rep faces>> [| count face |\r
- face selected face-selected? :> selected?\r
- face dup base-face>> eq? [\r
- face edge>> face-color\r
- selected? selected-face-color neutral-face-color ? v* :> color\r
- face triangulate-face seq>> :> triangles\r
- triangles members :> tri-vertices\r
- tri-vertices >index-hash :> vx-indices\r
-\r
- tri-vertices [\r
- position>> double-4>float-4 vertices push\r
- color vertices push\r
- ] each\r
- triangles [ vx-indices at count + indices push ] each\r
-\r
- count tri-vertices length +\r
- ] [ count ] if\r
- ] each :> total\r
- vertices float-4 >c-array underlying>>\r
- total\r
- indices ushort-array{ } like ;\r
-\r
-: b-rep-edge-vertices ( b-rep -- vertices count )\r
- vertices>> [\r
- [\r
- position>> [ double-4>float-4 ] keep\r
- [ drop neutral-edge-color ]\r
- [ vertex-color rgba>float-4 ] 2bi\r
- ] data-map( object -- float-4[4] )\r
- ] [ length 2 * ] bi ; inline\r
-\r
-GENERIC: selected-vectors ( object -- vectors )\r
-M: object selected-vectors drop { } ;\r
-M: double-4 selected-vectors 1array ;\r
-M: sequence selected-vectors [ selected-vectors ] map concat ;\r
-\r
-: selected-vertices ( selected -- vertices count )\r
- selected-vectors [\r
- [ [ double-4>float-4 ] [ vertex-color rgba>float-4 ] bi ]\r
- data-map( object -- float-4[2] )\r
- ] [ length ] bi ; inline\r
-\r
-: edge-vertex-index ( e vertex-indices selected -- n selected? )\r
- [ dup vertex>> ] [ at 2 * ] [ swapd in? [ [ 1 + ] when ] keep ] tri* ;\r
-\r
-:: b-rep-edge-index-array ( b-rep selected offset -- edge-indices )\r
- b-rep vertices>> >index-hash :> vertex-indices\r
- b-rep edges>> length <ushort-vector> :> edge-indices\r
-\r
- b-rep edges>> [| e |\r
- e opposite-edge>> :> o\r
- e vertex-indices selected edge-vertex-index [ offset + ] dip :> ( from e-selected? )\r
- o vertex-indices selected edge-vertex-index [ offset + ] dip :> ( to o-selected? )\r
-\r
- from to < [ from edge-indices push to edge-indices push ] when\r
- ] each\r
-\r
- edge-indices ushort-array{ } like ;\r
-\r
-:: make-b-rep-vertices ( b-rep selected -- vertices face-indices edge-indices point-indices )\r
- b-rep selected b-rep-face-vertices :> ( face-vertices face-count face-indices )\r
- b-rep b-rep-edge-vertices :> ( edge-vertices edge-count )\r
- selected selected-vertices :> ( sel-vertices sel-count )\r
- face-vertices face-count edge-vertices edge-count sel-vertices sel-count\r
- <b-rep-vertices> :> vertices\r
-\r
- vertices array>>\r
-\r
- face-indices\r
-\r
- b-rep selected vertices face-vertex-count>> b-rep-edge-index-array\r
- vertices\r
-\r
- [ face-vertex-count>> ]\r
- [ edge-vertex-count>> + dup ]\r
- [ point-vertex-count>> + ] tri\r
- [a,b) ushort >c-array ;\r
-\r
-VERTEX-FORMAT: wire-vertex-format\r
- { "vertex" float-components 3 f }\r
- { f float-components 1 f }\r
- { "color" float-components 4 f } ;\r
-\r
-GLSL-SHADER-FILE: gml-viewer-vertex-shader vertex-shader "viewer.v.glsl"\r
-GLSL-SHADER-FILE: gml-viewer-fragment-shader fragment-shader "viewer.f.glsl"\r
-GLSL-PROGRAM: gml-viewer-program\r
- gml-viewer-vertex-shader gml-viewer-fragment-shader\r
- wire-vertex-format ;\r
-\r
-TUPLE: gml-viewer-world < wasd-world\r
- { b-rep b-rep }\r
- selected\r
- program\r
- vertex-array\r
- face-indices edge-indices point-indices\r
- view-faces? view-edges?\r
- drag? ;\r
-\r
-TYPED: refresh-b-rep-view ( world: gml-viewer-world -- )\r
- dup control-value >>b-rep\r
- dup vertex-array>> [ vertex-array-buffer dispose ] when*\r
- dup [ b-rep>> ] [ selected>> value>> ] bi make-b-rep-vertices {\r
- [\r
- static-upload draw-usage vertex-buffer byte-array>buffer\r
- over program>> <vertex-array> >>vertex-array\r
- ]\r
- [ >>face-indices ]\r
- [ >>edge-indices ]\r
- [ >>point-indices ]\r
- } spread\r
- drop ;\r
-\r
-: viewable? ( gml-viewer-world -- ? )\r
- { [ b-rep>> ] [ program>> ] } 1&& ;\r
-\r
-M: gml-viewer-world model-changed\r
- nip\r
- [ control-value ]\r
- [ b-rep<< ]\r
- [ dup viewable? [ refresh-b-rep-view ] [ drop ] if ] tri ;\r
-\r
-: init-viewer-model ( gml-viewer-world -- )\r
- [ dup model>> add-connection ]\r
- [ dup selected>> add-connection ] bi ;\r
-\r
-: reset-view ( gml-viewer-world -- )\r
- { 0.0 0.0 5.0 } 0.0 0.0 set-wasd-view drop ;\r
-\r
-M: gml-viewer-world begin-game-world\r
- init-gpu\r
- t >>view-faces?\r
- t >>view-edges?\r
- T{ point-state { size 5.0 } } set-gpu-state\r
- dup reset-view\r
- gml-viewer-program <program-instance> >>program\r
- dup init-viewer-model\r
- refresh-b-rep-view ;\r
-\r
-M: gml-viewer-world end-game-world\r
- [ dup selected>> remove-connection ]\r
- [ dup model>> remove-connection ] bi ;\r
-\r
-M: gml-viewer-world draw-world*\r
- system-framebuffer {\r
- { default-attachment { 0.0 0.0 0.0 1.0 } }\r
- { depth-attachment 1.0 }\r
- } clear-framebuffer\r
-\r
- [\r
- dup view-faces?>> [\r
- T{ depth-state { comparison cmp-less } } set-gpu-state\r
- {\r
- { "primitive-mode" [ drop triangles-mode ] }\r
- { "indexes" [ face-indices>> ] }\r
- { "uniforms" [ <mvp-uniforms> ] }\r
- { "vertex-array" [ vertex-array>> ] }\r
- } <render-set> render\r
- T{ depth-state { comparison f } } set-gpu-state\r
- ] [ drop ] if\r
- ] [\r
- dup view-edges?>> [\r
- {\r
- { "primitive-mode" [ drop lines-mode ] }\r
- { "indexes" [ edge-indices>> ] }\r
- { "uniforms" [ <mvp-uniforms> ] }\r
- { "vertex-array" [ vertex-array>> ] }\r
- } <render-set> render\r
- ] [ drop ] if\r
- ] [\r
- {\r
- { "primitive-mode" [ drop points-mode ] }\r
- { "indexes" [ point-indices>> ] }\r
- { "uniforms" [ <mvp-uniforms> ] }\r
- { "vertex-array" [ vertex-array>> ] }\r
- } <render-set> render\r
- ] tri ;\r
-\r
-TYPED: rotate-view-mode ( world: gml-viewer-world -- )\r
- dup view-edges?>> [\r
- dup view-faces?>>\r
- [ f >>view-faces? ]\r
- [ f >>view-edges? t >>view-faces? ] if\r
- ] [ t >>view-edges? ] if drop ;\r
-\r
-CONSTANT: edge-hitbox-radius 0.05\r
-\r
-:: line-nearest-t ( p0 u q0 v -- tp tq )\r
- p0 q0 v- :> w0\r
-\r
- u u v. :> a\r
- u v v. :> b\r
- v v v. :> c\r
- u w0 v. :> d\r
- v w0 v. :> e\r
-\r
- a c * b b * - :> denom\r
-\r
- b e * c d * - denom /f\r
- a e * b d * - denom /f ;\r
-\r
-:: intersects-edge-node? ( source direction edge -- ? )\r
- edge vertex>> position>> double-4>float-4 :> edge-source\r
- edge opposite-edge>> vertex>> position>> double-4>float-4 edge-source v- :> edge-direction\r
-\r
- source direction edge-source edge-direction line-nearest-t :> ( ray-t edge-t )\r
-\r
- ray-t 0.0 >= edge-t 0.0 0.5 between? and [\r
- source direction ray-t v*n v+\r
- edge-source edge-direction edge-t v*n v+ v- norm\r
- edge-hitbox-radius <\r
- ] [ f ] if ;\r
-\r
-: intersecting-edge-node ( source direction b-rep -- edge/f )\r
- edges>> [ intersects-edge-node? ] 2with find nip ;\r
-\r
-: select-edge ( world -- )\r
- [ [ location>> ] [ hand-loc get wasd-pixel-ray ] bi ]\r
- [ b-rep>> intersecting-edge-node ]\r
- [ '[ _ [ selected>> push-model ] [ refresh-b-rep-view ] bi ] when* ] tri ;\r
-\r
-gml-viewer-world H{\r
- { T{ button-up f f 1 } [ dup drag?>> [ drop ] [ select-edge ] if ] }\r
- { T{ drag f 1 } [ t >>drag? drop ] }\r
- { T{ key-down f f "RET" } [ reset-view ] }\r
- { T{ key-down f f "TAB" } [ rotate-view-mode ] }\r
-} set-gestures\r
-\r
-AFTER: gml-viewer-world tick-game-world\r
- dup drag?>> [\r
- read-mouse buttons>>\r
- ! FIXME: GTK Mouse buttons are an integer\r
- ! MacOSX mouse buttons are an array of bools\r
- dup integer? [ 0 bit? ] [ first ] if >>drag?\r
- ] when drop ;\r
-\r
-M: gml-viewer-world wasd-mouse-scale drag?>> -1/600. 0.0 ? ;\r
-\r
-: wrap-in-model ( object -- model )\r
- dup model? [ <model> ] unless ;\r
-: wrap-in-growable-model ( object -- model )\r
- dup model? [\r
- dup growable? [ >vector ] unless\r
- <model>\r
- ] unless ;\r
-\r
-: gml-viewer ( b-rep selection -- )\r
- [ wrap-in-model ] [ wrap-in-growable-model ] bi*\r
- '[\r
- f T{ game-attributes\r
- { world-class gml-viewer-world }\r
- { title "GML wireframe viewer" }\r
- { pixel-format-attributes {\r
- windowed\r
- double-buffered\r
- T{ depth-bits f 16 }\r
- } }\r
- { grab-input? f }\r
- { use-game-input? t }\r
- { use-audio-engine? f }\r
- { pref-dim { 1024 768 } }\r
- { tick-interval-nanos $[ 30 fps ] }\r
- } open-window*\r
- _ >>model\r
- _ >>selected\r
- drop\r
- ] with-ui ;\r
+USING: accessors alien.c-types alien.data alien.data.map arrays
+assocs byte-arrays colors combinators combinators.short-circuit
+destructors euler.b-rep euler.b-rep.triangulation fry game.input
+game.loop game.models.half-edge game.worlds gml.printer gpu
+gpu.buffers gpu.framebuffers gpu.render gpu.shaders gpu.state
+gpu.util.wasd growable images kernel literals locals math
+math.order math.ranges math.vectors math.vectors.conversion
+math.vectors.simd math.vectors.simd.cords method-chains models
+namespaces sequences sets specialized-vectors typed ui
+ui.gadgets ui.gadgets.worlds ui.gestures ui.pixel-formats
+vectors ;
+FROM: math.matrices => m.v ;
+FROM: models => change-model ;
+SPECIALIZED-VECTORS: ushort float-4 ;
+IN: gml.viewer
+
+CONSTANT: neutral-edge-color float-4{ 1 1 1 1 }
+CONSTANT: neutral-face-color float-4{ 1 1 1 1 }
+CONSTANT: selected-face-color float-4{ 1 0.9 0.8 1 }
+
+: double-4>float-4 ( in: double-4 -- out: float-4 )
+ [ head>> ] [ tail>> ] bi double-2 float-4 vconvert ; inline
+: rgba>float-4 ( in: rgba -- out: float-4 )
+ >rgba-components float-4-boa ; inline
+
+: face-color ( edge -- color )
+ face-normal float-4{ 0 1 0.1 0 } v. 0.3 * 0.4 + dup dup 1.0 float-4-boa ; inline
+
+TUPLE: b-rep-vertices
+ { array byte-array read-only }
+ { face-vertex-count integer read-only }
+ { edge-vertex-count integer read-only }
+ { point-vertex-count integer read-only } ;
+
+:: <b-rep-vertices> ( face-array face-count
+ edge-array edge-count
+ point-array point-count -- vxs )
+ face-array edge-array point-array 3append
+ face-count edge-count point-count \ b-rep-vertices boa ; inline
+
+: face-selected? ( face selected -- ? )
+ [ f ] 2dip [ edge>> ] dip '[ _ in? or ] each-face-edge ;
+
+:: b-rep-face-vertices ( b-rep selected -- vertices count indices )
+ float-4-vector{ } clone :> vertices
+ ushort-vector{ } clone :> indices
+
+ 0 b-rep faces>> [| count face |
+ face selected face-selected? :> selected?
+ face dup base-face>> eq? [
+ face edge>> face-color
+ selected? selected-face-color neutral-face-color ? v* :> color
+ face triangulate-face seq>> :> triangles
+ triangles members :> tri-vertices
+ tri-vertices >index-hash :> vx-indices
+
+ tri-vertices [
+ position>> double-4>float-4 vertices push
+ color vertices push
+ ] each
+ triangles [ vx-indices at count + indices push ] each
+
+ count tri-vertices length +
+ ] [ count ] if
+ ] each :> total
+ vertices float-4 >c-array underlying>>
+ total
+ indices ushort-array{ } like ;
+
+: b-rep-edge-vertices ( b-rep -- vertices count )
+ vertices>> [
+ [
+ position>> [ double-4>float-4 ] keep
+ [ drop neutral-edge-color ]
+ [ vertex-color rgba>float-4 ] 2bi
+ ] data-map( object -- float-4[4] )
+ ] [ length 2 * ] bi ; inline
+
+GENERIC: selected-vectors ( object -- vectors )
+M: object selected-vectors drop { } ;
+M: double-4 selected-vectors 1array ;
+M: sequence selected-vectors [ selected-vectors ] map concat ;
+
+: selected-vertices ( selected -- vertices count )
+ selected-vectors [
+ [ [ double-4>float-4 ] [ vertex-color rgba>float-4 ] bi ]
+ data-map( object -- float-4[2] )
+ ] [ length ] bi ; inline
+
+: edge-vertex-index ( e vertex-indices selected -- n selected? )
+ [ dup vertex>> ] [ at 2 * ] [ swapd in? [ [ 1 + ] when ] keep ] tri* ;
+
+:: b-rep-edge-index-array ( b-rep selected offset -- edge-indices )
+ b-rep vertices>> >index-hash :> vertex-indices
+ b-rep edges>> length <ushort-vector> :> edge-indices
+
+ b-rep edges>> [| e |
+ e opposite-edge>> :> o
+ e vertex-indices selected edge-vertex-index [ offset + ] dip :> ( from e-selected? )
+ o vertex-indices selected edge-vertex-index [ offset + ] dip :> ( to o-selected? )
+
+ from to < [ from edge-indices push to edge-indices push ] when
+ ] each
+
+ edge-indices ushort-array{ } like ;
+
+:: make-b-rep-vertices ( b-rep selected -- vertices face-indices edge-indices point-indices )
+ b-rep selected b-rep-face-vertices :> ( face-vertices face-count face-indices )
+ b-rep b-rep-edge-vertices :> ( edge-vertices edge-count )
+ selected selected-vertices :> ( sel-vertices sel-count )
+ face-vertices face-count edge-vertices edge-count sel-vertices sel-count
+ <b-rep-vertices> :> vertices
+
+ vertices array>>
+
+ face-indices
+
+ b-rep selected vertices face-vertex-count>> b-rep-edge-index-array
+ vertices
+
+ [ face-vertex-count>> ]
+ [ edge-vertex-count>> + dup ]
+ [ point-vertex-count>> + ] tri
+ [a,b) ushort >c-array ;
+
+VERTEX-FORMAT: wire-vertex-format
+ { "vertex" float-components 3 f }
+ { f float-components 1 f }
+ { "color" float-components 4 f } ;
+
+GLSL-SHADER-FILE: gml-viewer-vertex-shader vertex-shader "viewer.v.glsl"
+GLSL-SHADER-FILE: gml-viewer-fragment-shader fragment-shader "viewer.f.glsl"
+GLSL-PROGRAM: gml-viewer-program
+ gml-viewer-vertex-shader gml-viewer-fragment-shader
+ wire-vertex-format ;
+
+TUPLE: gml-viewer-world < wasd-world
+ { b-rep b-rep }
+ selected
+ program
+ vertex-array
+ face-indices edge-indices point-indices
+ view-faces? view-edges?
+ drag? ;
+
+TYPED: refresh-b-rep-view ( world: gml-viewer-world -- )
+ dup control-value >>b-rep
+ dup vertex-array>> [ vertex-array-buffer dispose ] when*
+ dup [ b-rep>> ] [ selected>> value>> ] bi make-b-rep-vertices {
+ [
+ static-upload draw-usage vertex-buffer byte-array>buffer
+ over program>> <vertex-array> >>vertex-array
+ ]
+ [ >>face-indices ]
+ [ >>edge-indices ]
+ [ >>point-indices ]
+ } spread
+ drop ;
+
+: viewable? ( gml-viewer-world -- ? )
+ { [ b-rep>> ] [ program>> ] } 1&& ;
+
+M: gml-viewer-world model-changed
+ nip
+ [ control-value ]
+ [ b-rep<< ]
+ [ dup viewable? [ refresh-b-rep-view ] [ drop ] if ] tri ;
+
+: init-viewer-model ( gml-viewer-world -- )
+ [ dup model>> add-connection ]
+ [ dup selected>> add-connection ] bi ;
+
+: reset-view ( gml-viewer-world -- )
+ { 0.0 0.0 5.0 } 0.0 0.0 set-wasd-view drop ;
+
+M: gml-viewer-world begin-game-world
+ init-gpu
+ t >>view-faces?
+ t >>view-edges?
+ T{ point-state { size 5.0 } } set-gpu-state
+ dup reset-view
+ gml-viewer-program <program-instance> >>program
+ dup init-viewer-model
+ refresh-b-rep-view ;
+
+M: gml-viewer-world end-game-world
+ [ dup selected>> remove-connection ]
+ [ dup model>> remove-connection ] bi ;
+
+M: gml-viewer-world draw-world*
+ system-framebuffer {
+ { default-attachment { 0.0 0.0 0.0 1.0 } }
+ { depth-attachment 1.0 }
+ } clear-framebuffer
+
+ [
+ dup view-faces?>> [
+ T{ depth-state { comparison cmp-less } } set-gpu-state
+ {
+ { "primitive-mode" [ drop triangles-mode ] }
+ { "indexes" [ face-indices>> ] }
+ { "uniforms" [ <mvp-uniforms> ] }
+ { "vertex-array" [ vertex-array>> ] }
+ } <render-set> render
+ T{ depth-state { comparison f } } set-gpu-state
+ ] [ drop ] if
+ ] [
+ dup view-edges?>> [
+ {
+ { "primitive-mode" [ drop lines-mode ] }
+ { "indexes" [ edge-indices>> ] }
+ { "uniforms" [ <mvp-uniforms> ] }
+ { "vertex-array" [ vertex-array>> ] }
+ } <render-set> render
+ ] [ drop ] if
+ ] [
+ {
+ { "primitive-mode" [ drop points-mode ] }
+ { "indexes" [ point-indices>> ] }
+ { "uniforms" [ <mvp-uniforms> ] }
+ { "vertex-array" [ vertex-array>> ] }
+ } <render-set> render
+ ] tri ;
+
+TYPED: rotate-view-mode ( world: gml-viewer-world -- )
+ dup view-edges?>> [
+ dup view-faces?>>
+ [ f >>view-faces? ]
+ [ f >>view-edges? t >>view-faces? ] if
+ ] [ t >>view-edges? ] if drop ;
+
+CONSTANT: edge-hitbox-radius 0.05
+
+:: line-nearest-t ( p0 u q0 v -- tp tq )
+ p0 q0 v- :> w0
+
+ u u v. :> a
+ u v v. :> b
+ v v v. :> c
+ u w0 v. :> d
+ v w0 v. :> e
+
+ a c * b b * - :> denom
+
+ b e * c d * - denom /f
+ a e * b d * - denom /f ;
+
+:: intersects-edge-node? ( source direction edge -- ? )
+ edge vertex>> position>> double-4>float-4 :> edge-source
+ edge opposite-edge>> vertex>> position>> double-4>float-4 edge-source v- :> edge-direction
+
+ source direction edge-source edge-direction line-nearest-t :> ( ray-t edge-t )
+
+ ray-t 0.0 >= edge-t 0.0 0.5 between? and [
+ source direction ray-t v*n v+
+ edge-source edge-direction edge-t v*n v+ v- norm
+ edge-hitbox-radius <
+ ] [ f ] if ;
+
+: intersecting-edge-node ( source direction b-rep -- edge/f )
+ edges>> [ intersects-edge-node? ] 2with find nip ;
+
+: select-edge ( world -- )
+ [ [ location>> ] [ hand-loc get wasd-pixel-ray ] bi ]
+ [ b-rep>> intersecting-edge-node ]
+ [ '[ _ [ selected>> push-model ] [ refresh-b-rep-view ] bi ] when* ] tri ;
+
+gml-viewer-world H{
+ { T{ button-up f f 1 } [ dup drag?>> [ drop ] [ select-edge ] if ] }
+ { T{ drag f 1 } [ t >>drag? drop ] }
+ { T{ key-down f f "RET" } [ reset-view ] }
+ { T{ key-down f f "TAB" } [ rotate-view-mode ] }
+} set-gestures
+
+AFTER: gml-viewer-world tick-game-world
+ dup drag?>> [
+ read-mouse buttons>>
+ ! FIXME: GTK Mouse buttons are an integer
+ ! MacOSX mouse buttons are an array of bools
+ dup integer? [ 0 bit? ] [ first ] if >>drag?
+ ] when drop ;
+
+M: gml-viewer-world wasd-mouse-scale drag?>> -1/600. 0.0 ? ;
+
+: wrap-in-model ( object -- model )
+ dup model? [ <model> ] unless ;
+: wrap-in-growable-model ( object -- model )
+ dup model? [
+ dup growable? [ >vector ] unless
+ <model>
+ ] unless ;
+
+: gml-viewer ( b-rep selection -- )
+ [ wrap-in-model ] [ wrap-in-growable-model ] bi*
+ '[
+ f T{ game-attributes
+ { world-class gml-viewer-world }
+ { title "GML wireframe viewer" }
+ { pixel-format-attributes {
+ windowed
+ double-buffered
+ T{ depth-bits f 16 }
+ } }
+ { grab-input? f }
+ { use-game-input? t }
+ { use-audio-engine? f }
+ { pref-dim { 1024 768 } }
+ { tick-interval-nanos $[ 30 fps ] }
+ } open-window*
+ _ >>model
+ _ >>selected
+ drop
+ ] with-ui ;
projects / factor.git / blobdiff