-!IF DEFINED(DEBUG)\r
-LINK_FLAGS = /nologo /DEBUG shell32.lib\r
-CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG\r
-!ELSE\r
-LINK_FLAGS = /nologo shell32.lib\r
-CL_FLAGS = /nologo /O2 /W3\r
-!ENDIF\r
-\r
-EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res\r
-\r
-DLL_OBJS = vm\os-windows-nt.obj \\r
- vm\os-windows.obj \\r
- vm\aging_collector.obj \\r
- vm\alien.obj \\r
- vm\arrays.obj \\r
- vm\bignum.obj \\r
- vm\booleans.obj \\r
- vm\byte_arrays.obj \\r
- vm\callbacks.obj \\r
- vm\callstack.obj \\r
- vm\code_blocks.obj \\r
- vm\code_heap.obj \\r
- vm\compaction.obj \\r
- vm\contexts.obj \\r
- vm\data_heap.obj \\r
- vm\data_heap_checker.obj \\r
- vm\debug.obj \\r
- vm\dispatch.obj \\r
- vm\entry_points.obj \\r
- vm\errors.obj \\r
- vm\factor.obj \\r
- vm\free_list.obj \\r
- vm\full_collector.obj \\r
- vm\gc.obj \\r
- vm\image.obj \\r
- vm\inline_cache.obj \\r
- vm\instruction_operands.obj \\r
- vm\io.obj \\r
- vm\jit.obj \\r
- vm\math.obj \\r
- vm\nursery_collector.obj \\r
- vm\object_start_map.obj \\r
- vm\objects.obj \\r
- vm\primitives.obj \\r
- vm\profiler.obj \\r
- vm\quotations.obj \\r
- vm\run.obj \\r
- vm\strings.obj \\r
- vm\to_tenured_collector.obj \\r
- vm\tuples.obj \\r
- vm\utilities.obj \\r
- vm\vm.obj \\r
- vm\words.obj\r
-\r
-.cpp.obj:\r
- cl /EHsc $(CL_FLAGS) /Fo$@ /c $<\r
-\r
-.c.obj:\r
- cl $(CL_FLAGS) /Fo$@ /c $<\r
-\r
-.rs.res:\r
- rc $<\r
-\r
-all: factor.com factor.exe\r
-\r
-libfactor-ffi-test.dll: vm/ffi_test.obj\r
- link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj\r
-\r
-factor.dll.lib: $(DLL_OBJS)\r
- link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)\r
-\r
-factor.com: $(EXE_OBJS)\r
- link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS)\r
-\r
-factor.exe: $(EXE_OBJS)\r
- link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS)\r
-\r
-clean:\r
- del vm\*.obj\r
- del factor.lib\r
- del factor.com\r
- del factor.exe\r
- del factor.dll\r
- del factor.dll.lib\r
-\r
-.PHONY: all clean\r
-\r
-.SUFFIXES: .rs\r
+!IF DEFINED(DEBUG)
+LINK_FLAGS = /nologo /DEBUG shell32.lib
+CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG
+!ELSE
+LINK_FLAGS = /nologo shell32.lib
+CL_FLAGS = /nologo /O2 /W3
+!ENDIF
+
+EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res
+
+DLL_OBJS = vm\os-windows-nt.obj \
+ vm\os-windows.obj \
+ vm\aging_collector.obj \
+ vm\alien.obj \
+ vm\arrays.obj \
+ vm\bignum.obj \
+ vm\booleans.obj \
+ vm\byte_arrays.obj \
+ vm\callbacks.obj \
+ vm\callstack.obj \
+ vm\code_blocks.obj \
+ vm\code_heap.obj \
+ vm\compaction.obj \
+ vm\contexts.obj \
+ vm\data_heap.obj \
+ vm\data_heap_checker.obj \
+ vm\debug.obj \
+ vm\dispatch.obj \
+ vm\entry_points.obj \
+ vm\errors.obj \
+ vm\factor.obj \
+ vm\free_list.obj \
+ vm\full_collector.obj \
+ vm\gc.obj \
+ vm\image.obj \
+ vm\inline_cache.obj \
+ vm\instruction_operands.obj \
+ vm\io.obj \
+ vm\jit.obj \
+ vm\math.obj \
+ vm\nursery_collector.obj \
+ vm\object_start_map.obj \
+ vm\objects.obj \
+ vm\primitives.obj \
+ vm\profiler.obj \
+ vm\quotations.obj \
+ vm\run.obj \
+ vm\strings.obj \
+ vm\to_tenured_collector.obj \
+ vm\tuples.obj \
+ vm\utilities.obj \
+ vm\vm.obj \
+ vm\words.obj
+
+.cpp.obj:
+ cl /EHsc $(CL_FLAGS) /Fo$@ /c $<
+
+.c.obj:
+ cl $(CL_FLAGS) /Fo$@ /c $<
+
+.rs.res:
+ rc $<
+
+all: factor.com factor.exe
+
+libfactor-ffi-test.dll: vm/ffi_test.obj
+ link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj
+
+factor.dll.lib: $(DLL_OBJS)
+ link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)
+
+factor.com: $(EXE_OBJS)
+ link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS)
+
+factor.exe: $(EXE_OBJS)
+ link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS)
+
+clean:
+ del vm\*.obj
+ del factor.lib
+ del factor.com
+ del factor.exe
+ del factor.dll
+ del factor.dll.lib
+
+.PHONY: all clean
+
+.SUFFIXES: .rs
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.crossref help.stylesheet help.topics help.syntax
+definitions io prettyprint summary arrays math sequences vocabs strings
+see xml.data hashtables ;
+IN: collada
+
+ABOUT: "collada"
+
+ARTICLE: "collada" "Conversion of COLLADA assets"
+"The " { $vocab-link "collada" } " vocabulary implements words for converting COLLADA assets to data suitable for use with OpenGL. See the COLLADA documentation at " { $url "http://collada.org" } "." ;
+
+HELP: model
+{ $class-description "Tuple of a packed attribute buffer, index buffer and vertex format suitable for a single OpenGL draw call." } ;
+
+HELP: source
+{ $class-description "Tuple of a vertex attribute semantic, offset in triangle index buffer and float data for a single vertex attribute." } ;
+
+HELP: up-axis
+{ $description "Dynamically-scoped variable with the up axis of the tags being read." } ;
+
+HELP: unit-ratio
+{ $description "Scaling ratio for the coordinates of the tags being read." } ;
+
+HELP: missing-attr
+{ $description "An error thrown when an attribute is missing from a tag." } ;
+
+HELP: missing-child
+{ $description "An error thrown when a child is missing from a tag." } ;
+
+HELP: string>numbers ( string -- number-seq )
+{ $values { "string" string } { "number-seq" sequence } }
+{ $description "Splits a string on whitespace and converts the elements to a number sequence" } ;
+
+HELP: x-up { $class-description "Right-handed 3D coordinate system where X is up." } ;
+HELP: y-up { $class-description "Right-handed 3D coordinate system where Y is up." } ;
+HELP: z-up { $class-description "Right-handed 3D coordinate system where Z is up." } ;
+
+HELP: >y-up-axis!
+{ $values { "sequence" sequence } { "from-axis" rh-up } { "sequence" sequence } }
+{ $description "Destructively swizzles the first three elements of the input sequence to a right-handed 3D coordinate system where Y is up and returns the modified sequence." } ;
+
+HELP: source>seq
+{ $values { "source-tag" tag } { "up-axis" rh-up } { "scale" number } { "sequence" sequence } }
+{ $description "Convert the " { $emphasis "float_array" } " in a " { $emphasis "source tag" } " to a sequence of number sequences according to the element stride. The values are scaled according to " { $emphasis "scale" } " and swizzled from " { $emphasis "up-axis" } " so that the Y coordinate points up." } ;
+
+HELP: source>pair
+{ $values { "source-tag" tag } { "pair" pair } }
+{ $description "Convert the source tag to an id and number sequence pair." } ;
+
+HELP: mesh>sources
+{ $values { "mesh-tag" tag } { "hashtable" pair } }
+{ $description "Convert the mesh tag's source elements to a hashtable from id to number sequence." } ;
+
+HELP: mesh>vertices
+{ $values { "mesh-tag" tag } { "pair" pair } }
+{ $description "Convert the mesh tag's vertices element to a pair for further lookup in " { $link collect-sources } ". " } ;
+
+HELP: collect-sources
+{ $values { "sources" hashtable } { "vertices" pair } { "inputs" tag sequence } { "soures" sequence } }
+{ $description "Look up the sources for these " { $emphasis "input" } " elements and return a sequence of " { $link source } " tuples." } ;
+
+HELP: group-indices
+{ $values { "index-stride" number } { "triangle-count" number } { indices "sequence" } { "grouped-indices" sequence } }
+{ $description "Groups the index sequence by triangle and then groups each triangle's indices by vertex." } ;
+
+HELP: triangles>numbers
+{ $values { "triangles-tag" tag } { "number-seq" sequence } }
+{ $description "Converts the triangle data in a triangles tag from string form to a sequence of numbers." } ;
+
+HELP: largest-offset+1
+{ $values { "source-seq" sequence } { "largest-offset+1" number } }
+{ $description "Finds the largest offset in the sequence of " { $link source } " tuples and adds 1, which is the index stride for " { $link group-indices } "." } ;
+
+HELP: <model>
+{ $values { "attribute-buffer" sequence } { "index-buffer" sequence } { "sources" sequence } { "model" model } }
+{ $description "Converts the inputs to a form suitable for use with " { $vocab-link "gpu" } " and constructs a " { $link model } "." } ;
+
+HELP: soa>aos
+{ $values { "triangles-indices" sequence } { "sources" sequence } { "attribute-buffer" sequence } { "index-buffer" sequence } }
+{ $description "Swizzles the input sources from a structure of arrays form to an array of structures form and generates a new index buffer." } ;
+
+HELP: triangles>model
+{ $values { "sources" sequence } { "vertices" pair } { "triangles-tag" tag } { "model" model } }
+{ $description "Creates a " { $link model } " tuple from the given triangles tag, source set and vertices pair." } ;
+
+HELP: mesh>triangles
+{ $values { "souces" sequence } { "vertices" pair } { "mesh-tag" tag } { "models" sequence } }
+{ $description "Creates a sequence of models from the triangles in the mesh tag." } ;
+
+HELP: mesh>models
+{ $values { "mesh-tag" tag } { "models" sequence } }
+{ $description "Converts a triangle mesh to a set of models suitable for rendering with OpenGL." } ;
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs grouping hashtables kernel
+locals math math.parser sequences sequences.deep
+specialized-arrays.instances.alien.c-types.float
+specialized-arrays.instances.alien.c-types.uint splitting xml
+xml.data xml.traversal math.order
+namespaces combinators images gpu.shaders io ;
+IN: collada
+
+TUPLE: model attribute-buffer index-buffer vertex-format ;
+TUPLE: source semantic offset data ;
+
+SYMBOLS: up-axis unit-ratio ;
+
+ERROR: missing-attr tag attr ;
+ERROR: missing-child tag child-name ;
+
+: string>numbers ( string -- number-seq )
+ " \t\n" split [ string>number ] map ;
+
+: x/ ( tag child-name -- child-tag )
+ [ tag-named ]
+ [ rot dup [ drop missing-child ] unless 2nip ]
+ 2bi ; inline
+
+: x@ ( tag attr-name -- attr-value )
+ [ attr ]
+ [ rot dup [ drop missing-attr ] unless 2nip ]
+ 2bi ; inline
+
+: xt ( tag -- content ) children>string ;
+
+: x* ( tag child-name quot -- seq )
+ [ tags-named ] dip map ; inline
+
+SINGLETONS: x-up y-up z-up ;
+
+UNION: rh-up x-up y-up z-up ;
+
+GENERIC: >y-up-axis! ( seq from-axis -- seq )
+M: x-up >y-up-axis!
+ drop dup
+ [
+ [ 0 swap nth ]
+ [ 1 swap nth neg ]
+ [ 2 swap nth ] tri
+ swap -rot
+ ] [
+ [ 2 swap set-nth ]
+ [ 1 swap set-nth ]
+ [ 0 swap set-nth ] tri
+ ] bi ;
+M: y-up >y-up-axis! drop ;
+M: z-up >y-up-axis!
+ drop dup
+ [
+ [ 0 swap nth ]
+ [ 1 swap nth neg ]
+ [ 2 swap nth ] tri
+ swap
+ ] [
+ [ 2 swap set-nth ]
+ [ 1 swap set-nth ]
+ [ 0 swap set-nth ] tri
+ ] bi ;
+
+: source>seq ( source-tag up-axis scale -- sequence )
+ rot
+ [ "float_array" x/ xt string>numbers [ * ] with map ]
+ [ nip "technique_common" x/ "accessor" x/ "stride" x@ string>number ] 2bi
+ <groups>
+ [ swap >y-up-axis! ] with map ;
+
+: source>pair ( source-tag -- pair )
+ [ "id" x@ ]
+ [ up-axis get unit-ratio get source>seq ] bi 2array ;
+
+: mesh>sources ( mesh-tag -- hashtable )
+ "source" [ source>pair ] x* >hashtable ;
+
+: mesh>vertices ( mesh-tag -- pair )
+ "vertices" x/
+ [ "id" x@ ]
+ [ "input"
+ [
+ [ "semantic" x@ ]
+ [ "source" x@ ] bi 2array
+ ] x*
+ ] bi 2array ;
+
+:: collect-sources ( sources vertices inputs -- sources )
+ inputs
+ [| input |
+ input "source" x@ rest vertices first =
+ [
+ vertices second [| vertex |
+ vertex first
+ input "offset" x@ string>number
+ vertex second rest sources at source boa
+ ] map
+ ]
+ [
+ input [ "semantic" x@ ]
+ [ "offset" x@ string>number ]
+ [ "source" x@ rest sources at ] tri source boa
+ ] if
+ ] map flatten ;
+
+: group-indices ( index-stride triangle-count indices -- grouped-indices )
+ dup length rot / <groups> swap [ <groups> ] curry map ;
+
+: triangles>numbers ( triangles-tag -- number-seq )
+ "p" x/ children>string " \t\n" split [ string>number ] map ;
+
+: largest-offset+1 ( source-seq -- largest-offset+1 )
+ [ offset>> ] [ max ] map-reduce 1 + ;
+
+: <model> ( attribute-buffer index-buffer sources -- model )
+ [ flatten >float-array ]
+ [ flatten >uint-array ]
+ [
+ [
+ {
+ [ semantic>> ]
+ [ drop float-components ]
+ [ data>> first length ]
+ [ drop f ]
+ } cleave vertex-attribute boa
+ ] map
+ ] tri* model boa ;
+
+:: soa>aos ( triangles-indices sources -- attribute-buffer index-buffer )
+ V{ } clone :> attribute-buffer
+ V{ } clone :> index-buffer
+ H{ } clone :> inverse-attribute-buffer
+ triangles-indices [
+ [
+ [| triangle-index triangle-offset |
+ triangle-index triangle-offset sources
+ [| index offset source |
+ source offset>> offset = [
+ index source data>> nth
+ ] [ f ] if
+ ] with with map sift flatten :> attributes
+
+ attributes inverse-attribute-buffer at [
+ index-buffer push
+ ] [
+ attribute-buffer length
+ [ attributes inverse-attribute-buffer set-at ]
+ [ index-buffer push ] bi
+ attributes attribute-buffer push
+ ] if*
+ ] each-index
+ ] each
+ ] each
+ attribute-buffer index-buffer ;
+
+: triangles>model ( sources vertices triangles-tag -- model )
+ [ "input" tags-named collect-sources ] keep swap
+
+ [
+ largest-offset+1 swap
+ [ "count" x@ string>number ] [ triangles>numbers ] bi
+ group-indices
+ ]
+ [
+ [ soa>aos ] keep <model>
+ ] bi ;
+
+: mesh>triangles ( sources vertices mesh-tag -- models )
+ "triangles" tags-named [ triangles>model ] with with map ;
+
+: mesh>models ( mesh-tag -- models )
+ [
+ { { up-axis z-up } { unit-ratio 0.5 } } [
+ mesh>sources
+ ] bind
+ ]
+ [ mesh>vertices ]
+ [ mesh>triangles ] tri ;
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types arrays classes.struct combinators
+combinators.short-circuit game.loop game.worlds gpu gpu.buffers
+gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state
+gpu.textures gpu.util grouping http.client images images.loader
+io io.encodings.ascii io.files io.files.temp kernel locals math
+math.matrices math.vectors.simd math.parser math.vectors
+method-chains namespaces sequences splitting threads ui ui.gadgets
+ui.gadgets.worlds ui.pixel-formats specialized-arrays
+specialized-vectors literals collada fry xml xml.traversal sequences.deep
+
+opengl.gl
+prettyprint ;
+FROM: alien.c-types => float ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-VECTOR: uint
+IN: collada.viewer
+
+GLSL-SHADER: collada-vertex-shader vertex-shader
+uniform mat4 mv_matrix, p_matrix;
+uniform vec3 light_position;
+
+attribute vec3 POSITION;
+attribute vec3 NORMAL;
+
+void main()
+{
+ vec4 position = mv_matrix * vec4(POSITION, 1.0);
+ gl_Position = p_matrix * position;
+}
+;
+
+GLSL-SHADER: collada-fragment-shader fragment-shader
+void main()
+{
+ gl_FragColor = vec4(1, 1, 0, 1);
+}
+;
+
+GLSL-PROGRAM: collada-program
+ collada-vertex-shader collada-fragment-shader ;
+
+GLSL-SHADER: debug-vertex-shader vertex-shader
+uniform mat4 mv_matrix, p_matrix;
+uniform vec3 light_position;
+
+attribute vec3 POSITION;
+attribute vec3 COLOR;
+varying vec4 color;
+
+void main()
+{
+ gl_Position = p_matrix * mv_matrix * vec4(POSITION, 1.0);
+ color = vec4(COLOR, 1);
+}
+;
+
+GLSL-SHADER: debug-fragment-shader fragment-shader
+varying vec4 color;
+void main()
+{
+ gl_FragColor = color;
+}
+;
+
+GLSL-PROGRAM: debug-program debug-vertex-shader debug-fragment-shader ;
+
+UNIFORM-TUPLE: collada-uniforms < mvp-uniforms
+ { "light-position" vec3-uniform f } ;
+
+TUPLE: collada-state
+ models
+ vertex-arrays
+ index-vectors ;
+
+TUPLE: collada-world < wasd-world
+ { collada collada-state } ;
+
+VERTEX-FORMAT: collada-vertex
+ { "POSITION" float-components 3 f }
+ { "NORMAL" float-components 3 f } ;
+
+VERTEX-FORMAT: debug-vertex
+ { "POSITION" float-components 3 f }
+ { "COLOR" float-components 3 f } ;
+
+: <collada-buffers> ( models -- buffers )
+! drop
+! float-array{ -0.5 0 0 1 0 0 0 1 0 0 1 0 0.5 0 0 0 0 1 }
+! uint-array{ 0 1 2 }
+! f model boa 1array
+ [
+ [ attribute-buffer>> underlying>> static-upload draw-usage vertex-buffer byte-array>buffer ]
+ [ index-buffer>> underlying>> static-upload draw-usage index-buffer byte-array>buffer ]
+ [ index-buffer>> length ] tri 3array
+ ] map ;
+
+: fill-collada-state ( collada-state -- )
+ dup models>> <collada-buffers>
+ [
+ [
+ first collada-program <program-instance> collada-vertex buffer>vertex-array
+ ] map >>vertex-arrays drop
+ ]
+ [
+ [
+ [ second ] [ third ] bi
+ '[ _ 0 <buffer-ptr> _ uint-indexes <index-elements> ] call
+ ] map >>index-vectors drop
+ ] 2bi ;
+
+: <collada-state> ( -- collada-state )
+ collada-state new
+ #! "C:/Users/erikc/Downloads/mech.dae"
+ "/Users/erikc/Documents/mech.dae"
+ file>xml "mesh" deep-tags-named [ mesh>models ] map flatten >>models ;
+
+M: collada-world begin-game-world
+ init-gpu
+ { 0.0 0.0 2.0 } 0 0 set-wasd-view
+ <collada-state> [ fill-collada-state drop ] [ >>collada drop ] 2bi ;
+
+: <collada-uniforms> ( world -- uniforms )
+ [ wasd-mv-matrix ] [ wasd-p-matrix ] bi
+ { -10000.0 10000.0 10000.0 } ! light position
+ collada-uniforms boa ;
+
+: draw-line ( world from to color -- )
+ [ 3 head ] tri@ dup -rot append -rot append swap append >float-array
+ underlying>> stream-upload draw-usage vertex-buffer byte-array>buffer
+ debug-program <program-instance> debug-vertex buffer>vertex-array
+
+ { 0 1 } >uint-array stream-upload draw-usage index-buffer byte-array>buffer
+ 2 '[ _ 0 <buffer-ptr> _ uint-indexes <index-elements> ] call
+
+ rot <collada-uniforms>
+
+ {
+ { "primitive-mode" [ 3drop lines-mode ] }
+ { "uniforms" [ nip nip ] }
+ { "vertex-array" [ drop drop ] }
+ { "indexes" [ drop nip ] }
+ } 3<render-set> render ;
+
+: draw-lines ( world lines -- )
+ 3 <groups> [ first3 draw-line ] with each ; inline
+
+: draw-axes ( world -- )
+ { { 0 0 0 } { 1 0 0 } { 1 0 0 }
+ { 0 0 0 } { 0 1 0 } { 0 1 0 }
+ { 0 0 0 } { 0 0 1 } { 0 0 1 } } draw-lines ;
+
+: draw-collada ( world -- )
+ GL_COLOR_BUFFER_BIT glClear
+
+ [
+ triangle-lines dup t <triangle-state> set-gpu-state
+ [ collada>> vertex-arrays>> ]
+ [ collada>> index-vectors>> ]
+ [ <collada-uniforms> ]
+ tri
+ [
+ {
+ { "primitive-mode" [ 3drop triangles-mode ] }
+ { "uniforms" [ nip nip ] }
+ { "vertex-array" [ drop drop ] }
+ { "indexes" [ drop nip ] }
+ } 3<render-set> render
+ ] curry 2each
+ ]
+ [
+ draw-axes
+ ]
+ bi ;
+
+M: collada-world draw-world*
+ draw-collada ;
+
+M: collada-world wasd-movement-speed drop 1/16. ;
+M: collada-world wasd-near-plane drop 1/32. ;
+M: collada-world wasd-far-plane drop 1024.0 ;
+
+GAME: collada-game {
+ { world-class collada-world }
+ { title "Collada Viewer" }
+ { pixel-format-attributes {
+ windowed
+ double-buffered
+ } }
+ { grab-input? t }
+ { use-game-input? t }
+ { pref-dim { 1024 768 } }
+ { tick-interval-micros $[ 60 fps ] }
+ } ;
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: concurrency.futures concurrency.count-downs sequences\r
-kernel macros fry combinators generalizations ;\r
-IN: concurrency.combinators\r
-\r
-<PRIVATE\r
-\r
-: (parallel-each) ( n quot -- )\r
- [ <count-down> ] dip keep await ; inline\r
-\r
-PRIVATE>\r
-\r
-: parallel-each ( seq quot -- )\r
- over length [\r
- '[ _ curry _ spawn-stage ] each\r
- ] (parallel-each) ; inline\r
-\r
-: 2parallel-each ( seq1 seq2 quot -- )\r
- 2over min-length [\r
- '[ _ 2curry _ spawn-stage ] 2each\r
- ] (parallel-each) ; inline\r
-\r
-: parallel-filter ( seq quot -- newseq )\r
- over [ selector [ parallel-each ] dip ] dip like ; inline\r
-\r
-<PRIVATE\r
-\r
-: [future] ( quot -- quot' ) '[ _ curry future ] ; inline\r
-\r
-: future-values ( futures -- futures )\r
- [ ?future ] map! ; inline\r
-\r
-PRIVATE>\r
-\r
-: parallel-map ( seq quot -- newseq )\r
- [future] map future-values ; inline\r
-\r
-: 2parallel-map ( seq1 seq2 quot -- newseq )\r
- '[ _ 2curry future ] 2map future-values ;\r
-\r
-<PRIVATE\r
-\r
-: (parallel-spread) ( n -- spread-array )\r
- [ ?future ] <repetition> ; inline\r
-\r
-: (parallel-cleave) ( quots -- quot-array spread-array )\r
- [ [future] ] map dup length (parallel-spread) ; inline\r
-\r
-PRIVATE>\r
-\r
-MACRO: parallel-cleave ( quots -- )\r
- (parallel-cleave) '[ _ cleave _ spread ] ;\r
-\r
-MACRO: parallel-spread ( quots -- )\r
- (parallel-cleave) '[ _ spread _ spread ] ;\r
-\r
-MACRO: parallel-napply ( quot n -- )\r
- [ [future] ] dip dup (parallel-spread) '[ _ _ napply _ spread ] ;\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: concurrency.futures concurrency.count-downs sequences
+kernel macros fry combinators generalizations ;
+IN: concurrency.combinators
+
+<PRIVATE
+
+: (parallel-each) ( n quot -- )
+ [ <count-down> ] dip keep await ; inline
+
+PRIVATE>
+
+: parallel-each ( seq quot -- )
+ over length [
+ '[ _ curry _ spawn-stage ] each
+ ] (parallel-each) ; inline
+
+: 2parallel-each ( seq1 seq2 quot -- )
+ 2over min-length [
+ '[ _ 2curry _ spawn-stage ] 2each
+ ] (parallel-each) ; inline
+
+: parallel-filter ( seq quot -- newseq )
+ over [ selector [ parallel-each ] dip ] dip like ; inline
+
+<PRIVATE
+
+: [future] ( quot -- quot' ) '[ _ curry future ] ; inline
+
+: future-values ( futures -- futures )
+ [ ?future ] map! ; inline
+
+PRIVATE>
+
+: parallel-map ( seq quot -- newseq )
+ [future] map future-values ; inline
+
+: 2parallel-map ( seq1 seq2 quot -- newseq )
+ '[ _ 2curry future ] 2map future-values ;
+
+<PRIVATE
+
+: (parallel-spread) ( n -- spread-array )
+ [ ?future ] <repetition> ; inline
+
+: (parallel-cleave) ( quots -- quot-array spread-array )
+ [ [future] ] map dup length (parallel-spread) ; inline
+
+PRIVATE>
+
+MACRO: parallel-cleave ( quots -- )
+ (parallel-cleave) '[ _ cleave _ spread ] ;
+
+MACRO: parallel-spread ( quots -- )
+ (parallel-cleave) '[ _ spread _ spread ] ;
+
+MACRO: parallel-napply ( quot n -- )
+ [ [future] ] dip dup (parallel-spread) '[ _ _ napply _ spread ] ;
HOOK: read-controller game-input-backend ( controller -- controller-state )
HOOK: calibrate-controller game-input-backend ( controller -- )
+HOOK: vibrate-controller game-input-backend ( controller motor1 motor2 -- )
HOOK: read-keyboard game-input-backend ( -- keyboard-state )
call-next-method dup buttons>> clone >>buttons ;
{
- { [ os windows? ] [ "game.input.dinput" require ] }
+ { [ os windows? ] [ "game.input.xinput" require ] }
{ [ os macosx? ] [ "game.input.iokit" require ] }
{ [ t ] [ ] }
} cond
--- /dev/null
+Erik Charlebois
--- /dev/null
+XInput backend for game.input, borrows keyboard and mouse handling from game.input.dinput
--- /dev/null
+unportable
+games
--- /dev/null
+USING: game.input math math.order kernel macros fry sequences quotations
+arrays windows.directx.xinput combinators accessors windows.types
+game.input.dinput sequences.private namespaces classes.struct
+windows.errors windows.com.syntax io.encodings.utf16n alien.strings ;
+IN: game.input.xinput
+
+SINGLETON: xinput-game-input-backend
+
+xinput-game-input-backend game-input-backend set-global
+
+<PRIVATE
+: >axis ( short -- float )
+ 32768 /f ; inline
+: >trigger ( byte -- float )
+ 255 /f ; inline
+: >vibration ( float -- short )
+ 65535 * >fixnum 0 65535 clamp ; inline
+MACRO: map-index-compose ( seq quot -- seq )
+ '[ '[ _ execute _ ] _ compose ] map-index 1quotation ;
+
+: fill-buttons ( button-bitmap -- button-array )
+ 10 0.0 <array> dup rot >fixnum
+ { XINPUT_GAMEPAD_START
+ XINPUT_GAMEPAD_BACK
+ XINPUT_GAMEPAD_LEFT_THUMB
+ XINPUT_GAMEPAD_RIGHT_THUMB
+ XINPUT_GAMEPAD_LEFT_SHOULDER
+ XINPUT_GAMEPAD_RIGHT_SHOULDER
+ XINPUT_GAMEPAD_A
+ XINPUT_GAMEPAD_B
+ XINPUT_GAMEPAD_X
+ XINPUT_GAMEPAD_Y }
+ [ [ bitand ] dip swap 0 = [ 2drop ] [ 1.0 -rot swap set-nth ] if ]
+ map-index-compose 2cleave ;
+
+ : >pov ( byte -- symbol )
+ {
+ pov-neutral
+ pov-up
+ pov-down
+ pov-neutral
+ pov-left
+ pov-up-left
+ pov-down-left
+ pov-neutral
+ pov-right
+ pov-up-right
+ pov-down-right
+ pov-neutral
+ pov-neutral
+ pov-neutral
+ pov-neutral
+ pov-neutral
+ } nth ;
+
+: fill-controller-state ( XINPUT_STATE -- controller-state )
+ Gamepad>> controller-state new dup rot
+ {
+ [ wButtons>> HEX: f bitand >pov swap (>>pov) ]
+ [ wButtons>> fill-buttons swap (>>buttons) ]
+ [ sThumbLX>> >axis swap (>>x) ]
+ [ sThumbLY>> >axis swap (>>y) ]
+ [ sThumbRX>> >axis swap (>>rx) ]
+ [ sThumbRY>> >axis swap (>>ry) ]
+ [ bLeftTrigger>> >trigger swap (>>z) ]
+ [ bRightTrigger>> >trigger swap (>>rz) ]
+ } 2cleave ;
+PRIVATE>
+
+M: xinput-game-input-backend (open-game-input)
+ TRUE XInputEnable
+ create-dinput
+ create-device-change-window
+ find-keyboard
+ find-mouse
+ add-wm-devicechange ;
+
+M: xinput-game-input-backend (close-game-input)
+ remove-wm-devicechange
+ release-mouse
+ release-keyboard
+ close-device-change-window
+ delete-dinput
+ FALSE XInputEnable ;
+
+M: xinput-game-input-backend (reset-game-input)
+ global [
+ {
+ +dinput+ +keyboard-device+ +keyboard-state+
+ +controller-devices+ +controller-guids+
+ +device-change-window+ +device-change-handle+
+ } [ off ] each
+ ] bind ;
+
+M: xinput-game-input-backend get-controllers
+ { 0 1 2 3 } ;
+
+M: xinput-game-input-backend product-string
+ dup number?
+ [ drop "Controller (Xbox 360 Wireless Receiver for Windows)" ]
+ [ handle>> device-info tszProductName>> utf16n alien>string ]
+ if ;
+
+M: xinput-game-input-backend product-id
+ dup number?
+ [ drop GUID: {02a1045e-0000-0000-0000-504944564944} ]
+ [ handle>> device-info guidProduct>> ]
+ if ;
+
+M: xinput-game-input-backend instance-id
+ dup number?
+ [ drop GUID: {c6075b30-fbca-11de-8001-444553540000} ]
+ [ handle>> device-guid ]
+ if ;
+
+M: xinput-game-input-backend read-controller
+ XINPUT_STATE <struct> [ XInputGetState ] keep
+ swap drop fill-controller-state ;
+
+M: xinput-game-input-backend calibrate-controller drop ;
+
+M: xinput-game-input-backend vibrate-controller
+ [ >vibration ] bi@ XINPUT_VIBRATION <struct-boa> XInputSetState drop ;
+
+M: xinput-game-input-backend read-keyboard
+ +keyboard-device+ get
+ [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
+ [ ] [ f ] with-acquisition ;
+
+M: xinput-game-input-backend read-mouse
+ +mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ]
+ [ fill-mouse-state ] [ f ] with-acquisition ;
+
+M: xinput-game-input-backend reset-mouse
+ +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ]
+ [ 2drop ] [ ] with-acquisition
+ +mouse-state+ get
+ 0 >>dx
+ 0 >>dy
+ 0 >>scroll-dx
+ 0 >>scroll-dy
+ drop ;
--- /dev/null
+Erik Charlebois
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors images images.loader io io.binary kernel
+locals math sequences io.encodings.ascii io.encodings.string
+calendar math.ranges math.parser colors arrays hashtables
+ui.pixel-formats combinators continuations ;
+IN: images.tga
+
+SINGLETON: tga-image
+"tga" tga-image register-image-class
+
+ERROR: bad-tga-header ;
+ERROR: bad-tga-footer ;
+ERROR: bad-tga-extension-size ;
+ERROR: bad-tga-timestamp ;
+ERROR: bad-tga-unsupported ;
+
+: read-id-length ( -- byte )
+ 1 read le> ; inline
+
+: read-color-map-type ( -- byte )
+ 1 read le> dup
+ { 0 1 } member? [ bad-tga-header ] unless ;
+
+: read-image-type ( -- byte )
+ 1 read le> dup
+ { 0 1 2 3 9 10 11 } member? [ bad-tga-header ] unless ; inline
+
+: read-color-map-first ( -- short )
+ 2 read le> ; inline
+
+: read-color-map-length ( -- short )
+ 2 read le> ; inline
+
+: read-color-map-entry-size ( -- byte )
+ 1 read le> ; inline
+
+: read-x-origin ( -- short )
+ 2 read le> ; inline
+
+: read-y-origin ( -- short )
+ 2 read le> ; inline
+
+: read-image-width ( -- short )
+ 2 read le> ; inline
+
+: read-image-height ( -- short )
+ 2 read le> ; inline
+
+: read-pixel-depth ( -- byte )
+ 1 read le> ; inline
+
+: read-image-descriptor ( -- alpha-bits pixel-order )
+ 1 read le>
+ [ 7 bitand ] [ 24 bitand -3 shift ] bi ; inline
+
+: read-image-id ( length -- image-id )
+ read ; inline
+
+: read-color-map ( type length elt-size -- color-map )
+ pick 1 = [ 8 align 8 / * read ] [ 2drop f ] if swap drop ; inline
+
+: read-image-data ( width height depth -- image-data )
+ 8 align 8 / * * read ; inline
+
+: read-extension-area-offset ( -- offset )
+ 4 read le> ; inline
+
+: read-developer-directory-offset ( -- offset )
+ 4 read le> ; inline
+
+: read-signature ( -- )
+ 18 read ascii decode "TRUEVISION-XFILE.\0" = [ bad-tga-footer ] unless ; inline
+
+: read-extension-size ( -- )
+ 2 read le> 495 = [ bad-tga-extension-size ] unless ; inline
+
+: read-author-name ( -- string )
+ 41 read ascii decode [ 0 = ] trim ; inline
+
+: read-author-comments ( -- string )
+ 4 iota [ drop 81 read ascii decode [ 0 = ] trim ] map concat ; inline
+
+: read-date-timestamp ( -- timestamp )
+ timestamp new
+ 2 read le> dup 12 [1,b] member? [ bad-tga-timestamp ] unless >>month
+ 2 read le> dup 31 [1,b] member? [ bad-tga-timestamp ] unless >>day
+ 2 read le> >>year
+ 2 read le> dup 23 [0,b] member? [ bad-tga-timestamp ] unless >>hour
+ 2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>minute
+ 2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>second ; inline
+
+: read-job-name ( -- string )
+ 41 read ascii decode [ 0 = ] trim ; inline
+
+: read-job-time ( -- duration )
+ duration new
+ 2 read le> >>hour
+ 2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>minute
+ 2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>second ; inline
+
+: read-software-id ( -- string )
+ 41 read ascii decode [ 0 = ] trim ; inline
+
+: read-software-version ( -- string )
+ 2 read le> 100 /f number>string
+ 1 read ascii decode append [ " " = ] trim ; inline
+
+:: read-key-color ( -- color )
+ 1 read le> 255 /f :> alpha
+ 1 read le> 255 /f
+ 1 read le> 255 /f
+ 1 read le> 255 /f
+ alpha <rgba> ; inline
+
+: read-pixel-aspect-ratio ( -- aspect-ratio )
+ 2 read le> 2 read le> /f ; inline
+
+: read-gamma-value ( -- gamma-value )
+ 2 read le> 2 read le> /f ; inline
+
+: read-color-correction-offset ( -- offset )
+ 4 read le> ; inline
+
+: read-postage-stamp-offset ( -- offset )
+ 4 read le> ; inline
+
+: read-scan-line-offset ( -- offset )
+ 4 read le> ; inline
+
+: read-premultiplied-alpha ( -- boolean )
+ 1 read le> 4 = ; inline
+
+: read-scan-line-table ( height -- scan-offsets )
+ iota [ drop 4 read le> ] map ; inline
+
+: read-postage-stamp-image ( depth -- postage-data )
+ 8 align 8 / 1 read le> 1 read le> * * read ; inline
+
+:: read-color-correction-table ( -- correction-table )
+ 256 iota
+ [
+ drop
+ 4 iota
+ [
+ drop
+ 2 read le> 65535 /f :> alpha
+ 2 read le> 65535 /f
+ 2 read le> 65535 /f
+ 2 read le> 65535 /f
+ alpha <rgba>
+ ] map
+ ] map ; inline
+
+: read-developer-directory ( -- developer-directory )
+ 2 read le> iota
+ [
+ drop
+ 2 read le>
+ 4 read le>
+ 4 read le>
+ 3array
+ ] map ; inline
+
+: read-developer-areas ( developer-directory -- developer-area-map )
+ [
+ [ first ]
+ [ dup third second seek-absolute seek-input read ] bi 2array
+ ] map >hashtable ; inline
+
+:: read-tga ( -- image )
+ #! Read header
+ read-id-length :> id-length
+ read-color-map-type :> map-type
+ read-image-type :> image-type
+ read-color-map-first :> map-first
+ read-color-map-length :> map-length
+ read-color-map-entry-size :> map-entry-size
+ read-x-origin :> x-origin
+ read-y-origin :> y-origin
+ read-image-width :> image-width
+ read-image-height :> image-height
+ read-pixel-depth :> pixel-depth
+ read-image-descriptor :> ( alpha-bits pixel-order )
+ id-length read-image-id :> image-id
+ map-type map-length map-entry-size read-color-map :> color-map-data
+ image-width image-height pixel-depth read-image-data :> image-data
+
+ [
+ #! Read optional footer
+ 26 seek-end seek-input
+ read-extension-area-offset :> extension-offset
+ read-developer-directory-offset :> directory-offset
+ read-signature
+
+ #! Read optional extension section
+ extension-offset 0 =
+ [
+ extension-offset seek-absolute seek-input
+ read-extension-size
+ read-author-name :> author-name
+ read-author-comments :> author-comments
+ read-date-timestamp :> date-timestamp
+ read-job-name :> job-name
+ read-job-time :> job-time
+ read-software-id :> software-id
+ read-software-version :> software-version
+ read-key-color :> key-color
+ read-pixel-aspect-ratio :> aspect-ratio
+ read-gamma-value :> gamma-value
+ read-color-correction-offset :> color-correction-offset
+ read-postage-stamp-offset :> postage-stamp-offset
+ read-scan-line-offset :> scan-line-offset
+ read-premultiplied-alpha :> premultiplied-alpha
+
+ color-correction-offset 0 =
+ [
+ color-correction-offset seek-absolute seek-input
+ read-color-correction-table :> color-correction-table
+ ] unless
+
+ postage-stamp-offset 0 =
+ [
+ postage-stamp-offset seek-absolute seek-input
+ pixel-depth read-postage-stamp-image :> postage-data
+ ] unless
+
+ scan-line-offset seek-absolute seek-input
+ image-height read-scan-line-table :> scan-offsets
+
+ #! Read optional developer section
+ directory-offset 0 =
+ [ f ]
+ [
+ directory-offset seek-absolute seek-input
+ read-developer-directory read-developer-areas
+ ] if :> developer-areas
+ ] unless
+ ] ignore-errors
+
+ #! Only 24-bit uncompressed RGB and 32-bit uncompressed ARGB are supported.
+ #! Other formats would need to be converted to work within the image class.
+ map-type 0 = [ bad-tga-unsupported ] unless
+ image-type 2 = [ bad-tga-unsupported ] unless
+ pixel-depth { 24 32 } member? [ bad-tga-unsupported ] unless
+ pixel-order { 0 2 } member? [ bad-tga-unsupported ] unless
+
+ #! Create image instance
+ image new
+ alpha-bits 0 = [ RGB ] [ ARGB ] if >>component-order
+ { image-width image-height } >>dim
+ pixel-order 0 = >>upside-down?
+ image-data >>bitmap
+ ubyte-components >>component-type ;
+
+M: tga-image stream>image
+ drop [ read-tga ] with-input-stream ;
+
+M: tga-image image>stream
+ drop
+ [
+ component-order>> { RGB ARGB } member? [ bad-tga-unsupported ] unless
+ ] keep
+
+ B{ 0 } write #! id-length
+ B{ 0 } write #! map-type
+ B{ 2 } write #! image-type
+ B{ 0 0 0 0 0 } write #! color map first, length, entry size
+ B{ 0 0 0 0 } write #! x-origin, y-origin
+ {
+ [ dim>> first 2 >le write ]
+ [ dim>> second 2 >le write ]
+ [ component-order>>
+ {
+ { RGB [ B{ 24 } write ] }
+ { ARGB [ B{ 32 } write ] }
+ } case
+ ]
+ [
+ dup component-order>>
+ {
+ { RGB [ 0 ] }
+ { ARGB [ 8 ] }
+ } case swap
+ upside-down?>> [ 0 ] [ 2 ] if 3 shift bitor
+ 1 >le write
+ ]
+ [ bitmap>> write ]
+ } cleave ;
+
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax parser namespaces
kernel math windows.types generalizations math.bitwise
-classes.struct literals windows.kernel32 ;
+classes.struct literals windows.kernel32 system accessors ;
IN: windows.user32
! HKL for ActivateKeyboardLayout
CONSTANT: MF_RIGHTJUSTIFY HEX: 4000
CONSTANT: MF_MOUSESELECT HEX: 8000
+TYPEDEF: HANDLE HRAWINPUT
+: GET_RAWINPUT_CODE_WPARAM ( wParam -- n ) HEX: ff bitand ; inline
+
+CONSTANT: RIM_INPUT 0
+CONSTANT: RIM_INPUTSINK 1
+
+CONSTANT: RIM_TYPEMOUSE 0
+CONSTANT: RIM_TYPEKEYBOARD 1
+CONSTANT: RIM_TYPEHID 2
+
+STRUCT: RAWINPUTHEADER
+ { dwType DWORD }
+ { dwSize DWORD }
+ { hDevice HANDLE }
+ { wParam WPARAM } ;
+TYPEDEF: RAWINPUTHEADER* PRAWINPUTHEADER
+TYPEDEF: RAWINPUTHEADER* LPRAWINPUTHEADER
+STRUCT: RAWMOUSE_BUTTONS_USBUTTONS
+ { usButtonFlags USHORT }
+ { usButtonData USHORT } ;
+
+UNION-STRUCT: RAWMOUSE_BUTTONS
+ { ulButtons ULONG }
+ { usButtons RAWMOUSE_BUTTONS_USBUTTONS } ;
+STRUCT: RAWMOUSE
+ { usFlags USHORT }
+ { uButtons RAWMOUSE_BUTTONS }
+ { ulRawButtons ULONG }
+ { lLastX LONG }
+ { lLastY LONG }
+ { ulExtraInformation ULONG } ;
+TYPEDEF: RAWMOUSE* PRAWMOUSE
+TYPEDEF: RAWMOUSE* LPRAWMOUSE
+
+CONSTANT: RI_MOUSE_LEFT_BUTTON_DOWN HEX: 0001
+CONSTANT: RI_MOUSE_LEFT_BUTTON_UP HEX: 0002
+CONSTANT: RI_MOUSE_RIGHT_BUTTON_DOWN HEX: 0004
+CONSTANT: RI_MOUSE_RIGHT_BUTTON_UP HEX: 0008
+CONSTANT: RI_MOUSE_MIDDLE_BUTTON_DOWN HEX: 0010
+CONSTANT: RI_MOUSE_MIDDLE_BUTTON_UP HEX: 0020
+
+: RI_MOUSE_BUTTON_1_DOWN ( -- n ) RI_MOUSE_LEFT_BUTTON_DOWN ; inline
+: RI_MOUSE_BUTTON_1_UP ( -- n ) RI_MOUSE_LEFT_BUTTON_UP ; inline
+: RI_MOUSE_BUTTON_2_DOWN ( -- n ) RI_MOUSE_RIGHT_BUTTON_DOWN ; inline
+: RI_MOUSE_BUTTON_2_UP ( -- n ) RI_MOUSE_RIGHT_BUTTON_UP ; inline
+: RI_MOUSE_BUTTON_3_DOWN ( -- n ) RI_MOUSE_MIDDLE_BUTTON_DOWN ; inline
+: RI_MOUSE_BUTTON_3_UP ( -- n ) RI_MOUSE_MIDDLE_BUTTON_UP ; inline
+
+CONSTANT: RI_MOUSE_BUTTON_4_DOWN HEX: 0040
+CONSTANT: RI_MOUSE_BUTTON_4_UP HEX: 0080
+CONSTANT: RI_MOUSE_BUTTON_5_DOWN HEX: 0100
+CONSTANT: RI_MOUSE_BUTTON_5_UP HEX: 0200
+CONSTANT: RI_MOUSE_WHEEL HEX: 0400
+
+CONSTANT: MOUSE_MOVE_RELATIVE 0
+CONSTANT: MOUSE_MOVE_ABSOLUTE 1
+CONSTANT: MOUSE_VIRTUAL_DESKTOP HEX: 02
+CONSTANT: MOUSE_ATTRIBUTES_CHANGED HEX: 04
+CONSTANT: MOUSE_MOVE_NOCOALESCE HEX: 08
+
+STRUCT: RAWKEYBOARD
+ { MakeCode USHORT }
+ { Flags USHORT }
+ { Reserved USHORT }
+ { VKey USHORT }
+ { Message UINT }
+ { ExtraInformation ULONG } ;
+TYPEDEF: RAWKEYBOARD* PRAWKEYBOARD
+TYPEDEF: RAWKEYBOARD* LPRAWKEYBOARD
+
+CONSTANT: KEYBOARD_OVERRUN_MAKE_CODE HEX: FF
+
+CONSTANT: RI_KEY_MAKE 0
+CONSTANT: RI_KEY_BREAK 1
+CONSTANT: RI_KEY_E0 2
+CONSTANT: RI_KEY_E1 4
+CONSTANT: RI_KEY_TERMSRV_SET_LED 8
+CONSTANT: RI_KEY_TERMSRV_SHADOW HEX: 10
+
+STRUCT: RAWHID
+ { dwSizeHid DWORD }
+ { dwCount DWORD }
+ { bRawData BYTE[1] } ;
+TYPEDEF: RAWHID* PRAWHID
+TYPEDEF: RAWHID* LPRAWHID
+
+UNION-STRUCT: RAWINPUT_UNION
+ { mouse RAWMOUSE }
+ { keyboard RAWKEYBOARD }
+ { hid RAWHID } ;
+STRUCT: RAWINPUT
+ { header RAWINPUTHEADER }
+ { data RAWINPUT_UNION } ;
+TYPEDEF: RAWINPUT* PRAWINPUT
+TYPEDEF: RAWINPUT* LPRAWINPUT
+
+: RAWINPUT_ALIGN ( x -- y )
+ cpu x86.32 = [ 4 ] [ 8 ] if align ; inline
+: NEXTRAWINPUTBLOCK ( struct -- next-struct )
+ dup header>> dwSize>> swap <displaced-alien> RAWINPUT_ALIGN RAWINPUT memory>struct ; inline
+
+CONSTANT: RID_INPUT HEX: 10000003
+CONSTANT: RID_HEADER HEX: 10000005
+CONSTANT: RIDI_PREPARSEDDATA HEX: 20000005
+CONSTANT: RIDI_DEVICENAME HEX: 20000007
+CONSTANT: RIDI_DEVICEINFO HEX: 2000000b
+
+STRUCT: RID_DEVICE_INFO_MOUSE
+ { dwId DWORD }
+ { dwNumberOfButtons DWORD }
+ { dwSampleRate DWORD }
+ { fHasHorizontalWheel BOOL } ;
+TYPEDEF: RID_DEVICE_INFO_MOUSE* PRID_DEVICE_INFO_MOUSE
+
+STRUCT: RID_DEVICE_INFO_KEYBOARD
+ { dwType DWORD }
+ { dwSubType DWORD }
+ { dwKeyboardMode DWORD }
+ { dwNumberOfFunctionKeys DWORD }
+ { dwNumberOfIndicators DWORD }
+ { dwNumberOfKeysTotal DWORD } ;
+TYPEDEF: RID_DEVICE_INFO_KEYBOARD* PRID_DEVICE_INFO_KEYBOARD
+
+STRUCT: RID_DEVICE_INFO_HID
+ { dwVendorId DWORD }
+ { dwProductId DWORD }
+ { dwVersionNumber DWORD }
+ { usUsagePage USHORT }
+ { usUsage USHORT } ;
+TYPEDEF: RID_DEVICE_INFO_HID* PRID_DEVICE_INFO_HID
+
+UNION-STRUCT: RID_DEVICE_INFO_UNION
+ { mouse RID_DEVICE_INFO_MOUSE }
+ { keyboard RID_DEVICE_INFO_KEYBOARD }
+ { hid RID_DEVICE_INFO_HID } ;
+STRUCT: RID_DEVICE_INFO
+ { cbSize DWORD }
+ { dwType DWORD }
+ { data RID_DEVICE_INFO_UNION } ;
+TYPEDEF: RID_DEVICE_INFO* PRID_DEVICE_INFO
+TYPEDEF: RID_DEVICE_INFO* LPRID_DEVICE_INFO
+
+STRUCT: RAWINPUTDEVICE
+ { usUsagePage USHORT }
+ { usUsage USHORT }
+ { dwFlags DWORD }
+ { hwndTarget HWND } ;
+TYPEDEF: RAWINPUTDEVICE* PRAWINPUTDEVICE
+TYPEDEF: RAWINPUTDEVICE* LPRAWINPUTDEVICE
+TYPEDEF: RAWINPUTDEVICE* PCRAWINPUTDEVICE
+
+CONSTANT: RIDEV_REMOVE HEX: 00000001
+CONSTANT: RIDEV_EXCLUDE HEX: 00000010
+CONSTANT: RIDEV_PAGEONLY HEX: 00000020
+CONSTANT: RIDEV_NOLEGACY HEX: 00000030
+CONSTANT: RIDEV_INPUTSINK HEX: 00000100
+CONSTANT: RIDEV_CAPTUREMOUSE HEX: 00000200
+CONSTANT: RIDEV_NOHOTKEYS HEX: 00000200
+CONSTANT: RIDEV_APPKEYS HEX: 00000400
+CONSTANT: RIDEV_EXINPUTSINK HEX: 00001000
+CONSTANT: RIDEV_DEVNOTIFY HEX: 00002000
+CONSTANT: RIDEV_EXMODEMASK HEX: 000000F0
+
+: RIDEV_EXMODE ( mode -- x ) RIDEV_EXMODEMASK bitand ; inline
+
+CONSTANT: GIDC_ARRIVAL 1
+CONSTANT: GIDC_REMOVAL 2
+
+: GET_DEVICE_CHANGE_WPARAM ( wParam -- x ) HEX: ffff bitand ; inline
+
+STRUCT: RAWINPUTDEVICELIST
+ { hDevice HANDLE }
+ { dwType DWORD } ;
+TYPEDEF: RAWINPUTDEVICELIST* PRAWINPUTDEVICELIST
+
LIBRARY: user32
FUNCTION: HKL ActivateKeyboardLayout ( HKL hkl, UINT Flags ) ;
! FUNCTION: DefFrameProcW
! FUNCTION: DefMDIChildProcA
! FUNCTION: DefMDIChildProcW
-! FUNCTION: DefRawInputProc
+FUNCTION: LRESULT DefRawInputProc ( PRAWINPUT* paRawInput, INT nInput, UINT cbSizeHeader ) ;
FUNCTION: LRESULT DefWindowProcW ( HWND hWnd, UINT Msg, WPARAM wParam, LPARAM lParam ) ;
ALIAS: DefWindowProc DefWindowProcW
! FUNCTION: DeleteMenu
! FUNCTION: GetPropA
! FUNCTION: GetPropW
! FUNCTION: GetQueueStatus
-! FUNCTION: GetRawInputBuffer
-! FUNCTION: GetRawInputData
-! FUNCTION: GetRawInputDeviceInfoA
-! FUNCTION: GetRawInputDeviceInfoW
-! FUNCTION: GetRawInputDeviceList
+FUNCTION: UINT GetRawInputBuffer ( PRAWINPUT pData, PUINT pcbSize, UINT cbSizeHeader ) ;
+FUNCTION: UINT GetRawInputData ( HRAWINPUT hRawInput, UINT uiCommand, LPVOID pData, PUINT pcbSize, UINT cbSizeHeader ) ;
+FUNCTION: UINT GetRawInputDeviceInfoA ( HANDLE hDevice, UINT uiCommand, LPVOID pData, PUINT pcbSize ) ;
+FUNCTION: UINT GetRawInputDeviceInfoW ( HANDLE hDevice, UINT uiCommand, LPVOID pData, PUINT pcbSize ) ;
+ALIAS: GetRawInputDeviceInfo GetRawInputDeviceInfoW
+FUNCTION: UINT GetRawInputDeviceList ( PRAWINPUTDEVICELIST pRawInputDeviceList, PUINT puiNumDevices, UINT cbSize ) ;
+FUNCTION: UINT GetRegisteredRawInputDevices ( PRAWINPUTDEVICE pRawInputDevices, PUINT puiNumDevices, UINT cbSize ) ;
! FUNCTION: GetReasonTitleFromReasonCode
-! FUNCTION: GetRegisteredRawInputDevices
! FUNCTION: GetScrollBarInfo
! FUNCTION: GetScrollInfo
! FUNCTION: GetScrollPos
! FUNCTION: RegisterHotKey
! FUNCTION: RegisterLogonProcess
! FUNCTION: RegisterMessagePumpHook
-! FUNCTION: RegisterRawInputDevices
+FUNCTION: BOOL RegisterRawInputDevices ( PCRAWINPUTDEVICE pRawInputDevices, UINT uiNumDevices, UINT cbSize ) ;
! FUNCTION: RegisterServicesProcess
! FUNCTION: RegisterShellHookWindow
! FUNCTION: RegisterSystemThread
-USING: alien arrays definitions generic assocs hashtables io\r
-kernel math namespaces parser prettyprint sequences strings\r
-tools.test words quotations classes classes.algebra\r
-classes.private classes.union classes.mixin classes.predicate\r
-vectors source-files compiler.units growable random\r
-stack-checker effects kernel.private sbufs math.order\r
-classes.tuple accessors generic.private ;\r
-IN: classes.algebra.tests\r
-\r
-TUPLE: first-one ;\r
-TUPLE: second-one ;\r
-UNION: both first-one union-class ;\r
-\r
-PREDICATE: no-docs < word "documentation" word-prop not ;\r
-\r
-UNION: no-docs-union no-docs integer ;\r
-\r
-TUPLE: a ;\r
-TUPLE: b ;\r
-UNION: c a b ;\r
-\r
-TUPLE: tuple-example ;\r
-\r
-TUPLE: a1 ;\r
-TUPLE: b1 ;\r
-TUPLE: c1 ;\r
-\r
-UNION: x1 a1 b1 ;\r
-UNION: y1 a1 c1 ;\r
-UNION: z1 b1 c1 ;\r
-\r
-SINGLETON: sa\r
-SINGLETON: sb\r
-SINGLETON: sc\r
-\r
-INTERSECTION: empty-intersection ;\r
-\r
-INTERSECTION: generic-class generic class ;\r
-\r
-UNION: union-with-one-member a ;\r
-\r
-MIXIN: mixin-with-one-member\r
-INSTANCE: union-with-one-member mixin-with-one-member\r
-\r
-! class<=\r
-[ t ] [ \ fixnum \ integer class<= ] unit-test\r
-[ t ] [ \ fixnum \ fixnum class<= ] unit-test\r
-[ f ] [ \ integer \ fixnum class<= ] unit-test\r
-[ t ] [ \ integer \ object class<= ] unit-test\r
-[ f ] [ \ integer \ null class<= ] unit-test\r
-[ t ] [ \ null \ object class<= ] unit-test\r
-\r
-[ t ] [ \ generic \ word class<= ] unit-test\r
-[ f ] [ \ word \ generic class<= ] unit-test\r
-\r
-[ f ] [ \ reversed \ slice class<= ] unit-test\r
-[ f ] [ \ slice \ reversed class<= ] unit-test\r
-\r
-[ t ] [ no-docs no-docs-union class<= ] unit-test\r
-[ f ] [ no-docs-union no-docs class<= ] unit-test\r
-\r
-[ t ] [ \ c \ tuple class<= ] unit-test\r
-[ f ] [ \ tuple \ c class<= ] unit-test\r
-\r
-[ t ] [ \ tuple-class \ class class<= ] unit-test\r
-[ f ] [ \ class \ tuple-class class<= ] unit-test\r
-\r
-[ t ] [ \ null \ tuple-example class<= ] unit-test\r
-[ f ] [ \ object \ tuple-example class<= ] unit-test\r
-[ f ] [ \ object \ tuple-example class<= ] unit-test\r
-[ t ] [ \ tuple-example \ tuple class<= ] unit-test\r
-[ f ] [ \ tuple \ tuple-example class<= ] unit-test\r
-\r
-[ f ] [ z1 x1 y1 class-and class<= ] unit-test\r
-\r
-[ t ] [ x1 y1 class-and a1 class<= ] unit-test\r
-\r
-[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test\r
-\r
-[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test\r
-\r
-[ f ] [ growable tuple sequence class-and class<= ] unit-test\r
-\r
-[ f ] [ growable assoc class-and tuple class<= ] unit-test\r
-\r
-[ t ] [ object \ f \ f class-not class-or class<= ] unit-test\r
-\r
-[ t ] [ fixnum class-not integer class-and bignum class= ] unit-test\r
-\r
-[ t ] [ array number class-not class<= ] unit-test\r
-\r
-[ f ] [ bignum number class-not class<= ] unit-test\r
-\r
-[ t ] [ fixnum fixnum bignum class-or class<= ] unit-test\r
-\r
-[ f ] [ fixnum class-not integer class-and array class<= ] unit-test\r
-\r
-[ f ] [ fixnum class-not integer class<= ] unit-test\r
-\r
-[ f ] [ number class-not array class<= ] unit-test\r
-\r
-[ f ] [ fixnum class-not array class<= ] unit-test\r
-\r
-[ t ] [ number class-not integer class-not class<= ] unit-test\r
-\r
-[ f ] [ fixnum class-not integer class<= ] unit-test\r
-\r
-[ t ] [ object empty-intersection class<= ] unit-test\r
-[ t ] [ empty-intersection object class<= ] unit-test\r
-[ t ] [ \ f class-not empty-intersection class<= ] unit-test\r
-[ f ] [ empty-intersection \ f class-not class<= ] unit-test\r
-[ t ] [ \ number empty-intersection class<= ] unit-test\r
-[ t ] [ empty-intersection class-not null class<= ] unit-test\r
-[ t ] [ null empty-intersection class-not class<= ] unit-test\r
-\r
-[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test\r
-[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test\r
-\r
-[ t ] [ object \ f class-not \ f class-or class<= ] unit-test\r
-\r
-[ t ] [\r
- fixnum class-not\r
- fixnum fixnum class-not class-or\r
- class<=\r
-] unit-test\r
-\r
-[ t ] [ generic-class generic class<= ] unit-test\r
-[ t ] [ generic-class \ class class<= ] unit-test\r
-\r
-[ t ] [ a union-with-one-member class<= ] unit-test\r
-[ f ] [ union-with-one-member class-not integer class<= ] unit-test\r
-\r
-MIXIN: empty-mixin\r
-\r
-[ f ] [ empty-mixin class-not null class<= ] unit-test\r
-[ f ] [ empty-mixin null class<= ] unit-test\r
-\r
-[ t ] [ array sequence vector class-not class-and class<= ] unit-test\r
-[ f ] [ vector sequence vector class-not class-and class<= ] unit-test\r
-\r
-! class-and\r
-: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;\r
-\r
-[ t ] [ object object object class-and* ] unit-test\r
-[ t ] [ fixnum object fixnum class-and* ] unit-test\r
-[ t ] [ object fixnum fixnum class-and* ] unit-test\r
-[ t ] [ fixnum fixnum fixnum class-and* ] unit-test\r
-[ t ] [ fixnum integer fixnum class-and* ] unit-test\r
-[ t ] [ integer fixnum fixnum class-and* ] unit-test\r
-\r
-[ t ] [ vector fixnum null class-and* ] unit-test\r
-[ t ] [ number object number class-and* ] unit-test\r
-[ t ] [ object number number class-and* ] unit-test\r
-[ t ] [ slice reversed null class-and* ] unit-test\r
-[ t ] [ \ f class-not \ f null class-and* ] unit-test\r
-\r
-[ t ] [ vector array class-not vector class-and* ] unit-test\r
-\r
-! class-or\r
-: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;\r
-\r
-[ t ] [ \ f class-not \ f object class-or* ] unit-test\r
-\r
-! class-not\r
-[ vector ] [ vector class-not class-not ] unit-test\r
-\r
-! classes-intersect?\r
-[ t ] [ both tuple classes-intersect? ] unit-test\r
-\r
-[ f ] [ vector virtual-sequence classes-intersect? ] unit-test\r
-\r
-[ t ] [ number vector class-or sequence classes-intersect? ] unit-test\r
-\r
-[ f ] [ number vector class-and sequence classes-intersect? ] unit-test\r
-\r
-[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test\r
-\r
-[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test\r
-\r
-[ f ] [ integer integer class-not classes-intersect? ] unit-test\r
-\r
-[ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test\r
-\r
-[ t ] [ \ word generic-class classes-intersect? ] unit-test\r
-[ f ] [ number generic-class classes-intersect? ] unit-test\r
-\r
-[ f ] [ sa sb classes-intersect? ] unit-test\r
-\r
-[ t ] [ a union-with-one-member classes-intersect? ] unit-test\r
-[ f ] [ fixnum union-with-one-member classes-intersect? ] unit-test\r
-[ t ] [ object union-with-one-member classes-intersect? ] unit-test\r
-\r
-[ t ] [ union-with-one-member a classes-intersect? ] unit-test\r
-[ f ] [ union-with-one-member fixnum classes-intersect? ] unit-test\r
-[ t ] [ union-with-one-member object classes-intersect? ] unit-test\r
-\r
-[ t ] [ a mixin-with-one-member classes-intersect? ] unit-test\r
-[ f ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test\r
-[ t ] [ object mixin-with-one-member classes-intersect? ] unit-test\r
-\r
-[ t ] [ mixin-with-one-member a classes-intersect? ] unit-test\r
-[ f ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test\r
-[ t ] [ mixin-with-one-member object classes-intersect? ] unit-test\r
-\r
-! class=\r
-[ t ] [ null class-not object class= ] unit-test\r
-\r
-[ t ] [ object class-not null class= ] unit-test\r
-\r
-[ f ] [ object class-not object class= ] unit-test\r
-\r
-[ f ] [ null class-not null class= ] unit-test\r
-\r
-! class<=>\r
-\r
-[ +lt+ ] [ sequence object class<=> ] unit-test\r
-[ +gt+ ] [ object sequence class<=> ] unit-test\r
-[ +eq+ ] [ integer integer class<=> ] unit-test\r
-\r
-! smallest-class etc\r
-[ real ] [ { real sequence } smallest-class ] unit-test\r
-[ real ] [ { sequence real } smallest-class ] unit-test\r
-\r
-: min-class ( class classes -- class/f )\r
- interesting-classes smallest-class ;\r
-\r
-[ f ] [ fixnum { } min-class ] unit-test\r
-\r
-[ string ] [\r
- \ string\r
- [ integer string array reversed sbuf\r
- slice vector quotation ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ fixnum ] [\r
- \ fixnum\r
- [ fixnum integer object ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ integer ] [\r
- \ fixnum\r
- [ integer float object ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ object ] [\r
- \ word\r
- [ integer float object ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ reversed ] [\r
- \ reversed\r
- [ integer reversed slice ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ f ] [ null { number fixnum null } min-class ] unit-test\r
-\r
-! Test for hangs?\r
-: random-class ( -- class ) classes random ;\r
-\r
-: random-op ( -- word )\r
- {\r
- class-and\r
- class-or\r
- class-not\r
- } random ;\r
-\r
-10 [\r
- [ ] [\r
- 20 [ random-op ] [ ] replicate-as\r
- [ infer in>> length [ random-class ] times ] keep\r
- call\r
- drop\r
- ] unit-test\r
-] times\r
-\r
-: random-boolean ( -- ? )\r
- { t f } random ;\r
-\r
-: boolean>class ( ? -- class )\r
- object null ? ;\r
-\r
-: random-boolean-op ( -- word )\r
- {\r
- and\r
- or\r
- not\r
- xor\r
- } random ;\r
-\r
-: class-xor ( cls1 cls2 -- cls3 )\r
- [ class-or ] 2keep class-and class-not class-and ;\r
-\r
-: boolean-op>class-op ( word -- word' )\r
- {\r
- { and class-and }\r
- { or class-or }\r
- { not class-not }\r
- { xor class-xor }\r
- } at ;\r
-\r
-20 [\r
- [ t ] [\r
- 20 [ random-boolean-op ] [ ] replicate-as dup .\r
- [ infer in>> length [ random-boolean ] replicate dup . ] keep\r
- \r
- [ [ [ ] each ] dip call ] 2keep\r
- \r
- [ [ boolean>class ] each ] dip [ boolean-op>class-op ] map call object class=\r
- \r
- =\r
- ] unit-test\r
-] times\r
-\r
-SINGLETON: xxx\r
-UNION: yyy xxx ;\r
-\r
-[ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test\r
-[ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test\r
-\r
-[ { number ratio integer } ] [ { ratio number integer } sort-classes ] unit-test\r
-[ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test\r
-\r
-TUPLE: xa ;\r
-TUPLE: xb ;\r
-TUPLE: xc < xa ;\r
-TUPLE: xd < xb ;\r
-TUPLE: xe ;\r
-TUPLE: xf < xb ;\r
-TUPLE: xg < xb ;\r
-TUPLE: xh < xb ;\r
-\r
-[ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test\r
-\r
-[ H{ { word word } } ] [ \r
- generic-class flatten-class\r
-] unit-test\r
-\r
-[ sa ] [ sa { sa sb sc } min-class ] unit-test\r
-\r
-[ \ + flatten-class ] must-fail\r
+USING: alien arrays definitions generic assocs hashtables io
+kernel math namespaces parser prettyprint sequences strings
+tools.test words quotations classes classes.algebra
+classes.private classes.union classes.mixin classes.predicate
+vectors source-files compiler.units growable random
+stack-checker effects kernel.private sbufs math.order
+classes.tuple accessors generic.private ;
+IN: classes.algebra.tests
+
+TUPLE: first-one ;
+TUPLE: second-one ;
+UNION: both first-one union-class ;
+
+PREDICATE: no-docs < word "documentation" word-prop not ;
+
+UNION: no-docs-union no-docs integer ;
+
+TUPLE: a ;
+TUPLE: b ;
+UNION: c a b ;
+
+TUPLE: tuple-example ;
+
+TUPLE: a1 ;
+TUPLE: b1 ;
+TUPLE: c1 ;
+
+UNION: x1 a1 b1 ;
+UNION: y1 a1 c1 ;
+UNION: z1 b1 c1 ;
+
+SINGLETON: sa
+SINGLETON: sb
+SINGLETON: sc
+
+INTERSECTION: empty-intersection ;
+
+INTERSECTION: generic-class generic class ;
+
+UNION: union-with-one-member a ;
+
+MIXIN: mixin-with-one-member
+INSTANCE: union-with-one-member mixin-with-one-member
+
+! class<=
+[ t ] [ \ fixnum \ integer class<= ] unit-test
+[ t ] [ \ fixnum \ fixnum class<= ] unit-test
+[ f ] [ \ integer \ fixnum class<= ] unit-test
+[ t ] [ \ integer \ object class<= ] unit-test
+[ f ] [ \ integer \ null class<= ] unit-test
+[ t ] [ \ null \ object class<= ] unit-test
+
+[ t ] [ \ generic \ word class<= ] unit-test
+[ f ] [ \ word \ generic class<= ] unit-test
+
+[ f ] [ \ reversed \ slice class<= ] unit-test
+[ f ] [ \ slice \ reversed class<= ] unit-test
+
+[ t ] [ no-docs no-docs-union class<= ] unit-test
+[ f ] [ no-docs-union no-docs class<= ] unit-test
+
+[ t ] [ \ c \ tuple class<= ] unit-test
+[ f ] [ \ tuple \ c class<= ] unit-test
+
+[ t ] [ \ tuple-class \ class class<= ] unit-test
+[ f ] [ \ class \ tuple-class class<= ] unit-test
+
+[ t ] [ \ null \ tuple-example class<= ] unit-test
+[ f ] [ \ object \ tuple-example class<= ] unit-test
+[ f ] [ \ object \ tuple-example class<= ] unit-test
+[ t ] [ \ tuple-example \ tuple class<= ] unit-test
+[ f ] [ \ tuple \ tuple-example class<= ] unit-test
+
+[ f ] [ z1 x1 y1 class-and class<= ] unit-test
+
+[ t ] [ x1 y1 class-and a1 class<= ] unit-test
+
+[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test
+
+[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test
+
+[ f ] [ growable tuple sequence class-and class<= ] unit-test
+
+[ f ] [ growable assoc class-and tuple class<= ] unit-test
+
+[ t ] [ object \ f \ f class-not class-or class<= ] unit-test
+
+[ t ] [ fixnum class-not integer class-and bignum class= ] unit-test
+
+[ t ] [ array number class-not class<= ] unit-test
+
+[ f ] [ bignum number class-not class<= ] unit-test
+
+[ t ] [ fixnum fixnum bignum class-or class<= ] unit-test
+
+[ f ] [ fixnum class-not integer class-and array class<= ] unit-test
+
+[ f ] [ fixnum class-not integer class<= ] unit-test
+
+[ f ] [ number class-not array class<= ] unit-test
+
+[ f ] [ fixnum class-not array class<= ] unit-test
+
+[ t ] [ number class-not integer class-not class<= ] unit-test
+
+[ f ] [ fixnum class-not integer class<= ] unit-test
+
+[ t ] [ object empty-intersection class<= ] unit-test
+[ t ] [ empty-intersection object class<= ] unit-test
+[ t ] [ \ f class-not empty-intersection class<= ] unit-test
+[ f ] [ empty-intersection \ f class-not class<= ] unit-test
+[ t ] [ \ number empty-intersection class<= ] unit-test
+[ t ] [ empty-intersection class-not null class<= ] unit-test
+[ t ] [ null empty-intersection class-not class<= ] unit-test
+
+[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test
+[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test
+
+[ t ] [ object \ f class-not \ f class-or class<= ] unit-test
+
+[ t ] [
+ fixnum class-not
+ fixnum fixnum class-not class-or
+ class<=
+] unit-test
+
+[ t ] [ generic-class generic class<= ] unit-test
+[ t ] [ generic-class \ class class<= ] unit-test
+
+[ t ] [ a union-with-one-member class<= ] unit-test
+[ f ] [ union-with-one-member class-not integer class<= ] unit-test
+
+MIXIN: empty-mixin
+
+[ f ] [ empty-mixin class-not null class<= ] unit-test
+[ f ] [ empty-mixin null class<= ] unit-test
+
+[ t ] [ array sequence vector class-not class-and class<= ] unit-test
+[ f ] [ vector sequence vector class-not class-and class<= ] unit-test
+
+! class-and
+: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
+
+[ t ] [ object object object class-and* ] unit-test
+[ t ] [ fixnum object fixnum class-and* ] unit-test
+[ t ] [ object fixnum fixnum class-and* ] unit-test
+[ t ] [ fixnum fixnum fixnum class-and* ] unit-test
+[ t ] [ fixnum integer fixnum class-and* ] unit-test
+[ t ] [ integer fixnum fixnum class-and* ] unit-test
+
+[ t ] [ vector fixnum null class-and* ] unit-test
+[ t ] [ number object number class-and* ] unit-test
+[ t ] [ object number number class-and* ] unit-test
+[ t ] [ slice reversed null class-and* ] unit-test
+[ t ] [ \ f class-not \ f null class-and* ] unit-test
+
+[ t ] [ vector array class-not vector class-and* ] unit-test
+
+! class-or
+: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;
+
+[ t ] [ \ f class-not \ f object class-or* ] unit-test
+
+! class-not
+[ vector ] [ vector class-not class-not ] unit-test
+
+! classes-intersect?
+[ t ] [ both tuple classes-intersect? ] unit-test
+
+[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
+
+[ t ] [ number vector class-or sequence classes-intersect? ] unit-test
+
+[ f ] [ number vector class-and sequence classes-intersect? ] unit-test
+
+[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test
+
+[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
+
+[ f ] [ integer integer class-not classes-intersect? ] unit-test
+
+[ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test
+
+[ t ] [ \ word generic-class classes-intersect? ] unit-test
+[ f ] [ number generic-class classes-intersect? ] unit-test
+
+[ f ] [ sa sb classes-intersect? ] unit-test
+
+[ t ] [ a union-with-one-member classes-intersect? ] unit-test
+[ f ] [ fixnum union-with-one-member classes-intersect? ] unit-test
+[ t ] [ object union-with-one-member classes-intersect? ] unit-test
+
+[ t ] [ union-with-one-member a classes-intersect? ] unit-test
+[ f ] [ union-with-one-member fixnum classes-intersect? ] unit-test
+[ t ] [ union-with-one-member object classes-intersect? ] unit-test
+
+[ t ] [ a mixin-with-one-member classes-intersect? ] unit-test
+[ f ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test
+[ t ] [ object mixin-with-one-member classes-intersect? ] unit-test
+
+[ t ] [ mixin-with-one-member a classes-intersect? ] unit-test
+[ f ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test
+[ t ] [ mixin-with-one-member object classes-intersect? ] unit-test
+
+! class=
+[ t ] [ null class-not object class= ] unit-test
+
+[ t ] [ object class-not null class= ] unit-test
+
+[ f ] [ object class-not object class= ] unit-test
+
+[ f ] [ null class-not null class= ] unit-test
+
+! class<=>
+
+[ +lt+ ] [ sequence object class<=> ] unit-test
+[ +gt+ ] [ object sequence class<=> ] unit-test
+[ +eq+ ] [ integer integer class<=> ] unit-test
+
+! smallest-class etc
+[ real ] [ { real sequence } smallest-class ] unit-test
+[ real ] [ { sequence real } smallest-class ] unit-test
+
+: min-class ( class classes -- class/f )
+ interesting-classes smallest-class ;
+
+[ f ] [ fixnum { } min-class ] unit-test
+
+[ string ] [
+ \ string
+ [ integer string array reversed sbuf
+ slice vector quotation ]
+ sort-classes min-class
+] unit-test
+
+[ fixnum ] [
+ \ fixnum
+ [ fixnum integer object ]
+ sort-classes min-class
+] unit-test
+
+[ integer ] [
+ \ fixnum
+ [ integer float object ]
+ sort-classes min-class
+] unit-test
+
+[ object ] [
+ \ word
+ [ integer float object ]
+ sort-classes min-class
+] unit-test
+
+[ reversed ] [
+ \ reversed
+ [ integer reversed slice ]
+ sort-classes min-class
+] unit-test
+
+[ f ] [ null { number fixnum null } min-class ] unit-test
+
+! Test for hangs?
+: random-class ( -- class ) classes random ;
+
+: random-op ( -- word )
+ {
+ class-and
+ class-or
+ class-not
+ } random ;
+
+10 [
+ [ ] [
+ 20 [ random-op ] [ ] replicate-as
+ [ infer in>> length [ random-class ] times ] keep
+ call
+ drop
+ ] unit-test
+] times
+
+: random-boolean ( -- ? )
+ { t f } random ;
+
+: boolean>class ( ? -- class )
+ object null ? ;
+
+: random-boolean-op ( -- word )
+ {
+ and
+ or
+ not
+ xor
+ } random ;
+
+: class-xor ( cls1 cls2 -- cls3 )
+ [ class-or ] 2keep class-and class-not class-and ;
+
+: boolean-op>class-op ( word -- word' )
+ {
+ { and class-and }
+ { or class-or }
+ { not class-not }
+ { xor class-xor }
+ } at ;
+
+20 [
+ [ t ] [
+ 20 [ random-boolean-op ] [ ] replicate-as dup .
+ [ infer in>> length [ random-boolean ] replicate dup . ] keep
+
+ [ [ [ ] each ] dip call ] 2keep
+
+ [ [ boolean>class ] each ] dip [ boolean-op>class-op ] map call object class=
+
+ =
+ ] unit-test
+] times
+
+SINGLETON: xxx
+UNION: yyy xxx ;
+
+[ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test
+[ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test
+
+[ { number ratio integer } ] [ { ratio number integer } sort-classes ] unit-test
+[ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test
+
+TUPLE: xa ;
+TUPLE: xb ;
+TUPLE: xc < xa ;
+TUPLE: xd < xb ;
+TUPLE: xe ;
+TUPLE: xf < xb ;
+TUPLE: xg < xb ;
+TUPLE: xh < xb ;
+
+[ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test
+
+[ H{ { word word } } ] [
+ generic-class flatten-class
+] unit-test
+
+[ sa ] [ sa { sa sb sc } min-class ] unit-test
+
+[ \ + flatten-class ] must-fail
-! Copyright (C) 2004, 2010 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel classes combinators accessors sequences arrays\r
-vectors assocs namespaces words sorting layouts math hashtables\r
-kernel.private sets math.order ;\r
-IN: classes.algebra\r
-\r
-<PRIVATE\r
-\r
-TUPLE: anonymous-union { members read-only } ;\r
-\r
-: <anonymous-union> ( members -- class )\r
- [ null eq? not ] filter prune\r
- dup length 1 = [ first ] [ anonymous-union boa ] if ;\r
-\r
-TUPLE: anonymous-intersection { participants read-only } ;\r
-\r
-: <anonymous-intersection> ( participants -- class )\r
- prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ;\r
-\r
-TUPLE: anonymous-complement { class read-only } ;\r
-\r
-C: <anonymous-complement> anonymous-complement\r
-\r
-DEFER: (class<=)\r
-\r
-DEFER: (class-not)\r
-\r
-GENERIC: (classes-intersect?) ( first second -- ? )\r
-\r
-DEFER: (class-and)\r
-\r
-DEFER: (class-or)\r
-\r
-GENERIC: (flatten-class) ( class -- )\r
-\r
-GENERIC: normalize-class ( class -- class' )\r
-\r
-M: object normalize-class ;\r
-\r
-PRIVATE>\r
-\r
-GENERIC: classoid? ( obj -- ? )\r
-\r
-M: word classoid? class? ;\r
-M: anonymous-union classoid? members>> [ classoid? ] all? ;\r
-M: anonymous-intersection classoid? participants>> [ classoid? ] all? ;\r
-M: anonymous-complement classoid? class>> classoid? ;\r
-\r
-: class<= ( first second -- ? )\r
- class<=-cache get [ (class<=) ] 2cache ;\r
-\r
-: class< ( first second -- ? )\r
- {\r
- { [ 2dup class<= not ] [ 2drop f ] }\r
- { [ 2dup swap class<= not ] [ 2drop t ] }\r
- [ [ rank-class ] bi@ < ]\r
- } cond ;\r
-\r
-: class<=> ( first second -- ? )\r
- {\r
- { [ 2dup class<= not ] [ 2drop +gt+ ] }\r
- { [ 2dup swap class<= not ] [ 2drop +lt+ ] }\r
- [ [ rank-class ] bi@ <=> ]\r
- } cond ;\r
-\r
-: class= ( first second -- ? )\r
- [ class<= ] [ swap class<= ] 2bi and ;\r
-\r
-: class-not ( class -- complement )\r
- class-not-cache get [ (class-not) ] cache ;\r
-\r
-: classes-intersect? ( first second -- ? )\r
- classes-intersect-cache get [\r
- normalize-class (classes-intersect?)\r
- ] 2cache ;\r
-\r
-: class-and ( first second -- class )\r
- class-and-cache get [ (class-and) ] 2cache ;\r
-\r
-: class-or ( first second -- class )\r
- class-or-cache get [ (class-or) ] 2cache ;\r
-\r
-<PRIVATE\r
-\r
-: superclass<= ( first second -- ? )\r
- swap superclass dup [ swap class<= ] [ 2drop f ] if ;\r
-\r
-: left-anonymous-union<= ( first second -- ? )\r
- [ members>> ] dip [ class<= ] curry all? ;\r
-\r
-: right-union<= ( first second -- ? )\r
- members [ class<= ] with any? ;\r
-\r
-: right-anonymous-union<= ( first second -- ? )\r
- members>> [ class<= ] with any? ;\r
-\r
-: left-anonymous-intersection<= ( first second -- ? )\r
- [ participants>> ] dip [ class<= ] curry any? ;\r
-\r
-: right-anonymous-intersection<= ( first second -- ? )\r
- participants>> [ class<= ] with all? ;\r
-\r
-: anonymous-complement<= ( first second -- ? )\r
- [ class>> ] bi@ swap class<= ;\r
-\r
-: normalize-complement ( class -- class' )\r
- class>> normalize-class {\r
- { [ dup anonymous-union? ] [\r
- members>>\r
- [ class-not normalize-class ] map\r
- <anonymous-intersection> \r
- ] }\r
- { [ dup anonymous-intersection? ] [\r
- participants>>\r
- [ class-not normalize-class ] map\r
- <anonymous-union>\r
- ] }\r
- [ drop object ]\r
- } cond ;\r
-\r
-: left-anonymous-complement<= ( first second -- ? )\r
- [ normalize-complement ] dip class<= ;\r
-\r
-PREDICATE: nontrivial-anonymous-complement < anonymous-complement\r
- class>> {\r
- [ anonymous-union? ]\r
- [ anonymous-intersection? ]\r
- [ members ]\r
- [ participants ]\r
- } cleave or or or ;\r
-\r
-PREDICATE: empty-union < anonymous-union members>> empty? ;\r
-\r
-PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;\r
-\r
-: (class<=) ( first second -- ? )\r
- 2dup eq? [ 2drop t ] [\r
- [ normalize-class ] bi@\r
- 2dup superclass<= [ 2drop t ] [\r
- {\r
- { [ 2dup eq? ] [ 2drop t ] }\r
- { [ dup empty-intersection? ] [ 2drop t ] }\r
- { [ over empty-union? ] [ 2drop t ] }\r
- { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }\r
- { [ over anonymous-union? ] [ left-anonymous-union<= ] }\r
- { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }\r
- { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }\r
- { [ dup members ] [ right-union<= ] }\r
- { [ dup anonymous-union? ] [ right-anonymous-union<= ] }\r
- { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }\r
- { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }\r
- [ 2drop f ]\r
- } cond\r
- ] if\r
- ] if ;\r
-\r
-M: anonymous-union (classes-intersect?)\r
- members>> [ classes-intersect? ] with any? ;\r
-\r
-M: anonymous-intersection (classes-intersect?)\r
- participants>> [ classes-intersect? ] with all? ;\r
-\r
-M: anonymous-complement (classes-intersect?)\r
- class>> class<= not ;\r
-\r
-: anonymous-union-and ( first second -- class )\r
- members>> [ class-and ] with map <anonymous-union> ;\r
-\r
-: anonymous-intersection-and ( first second -- class )\r
- participants>> swap suffix <anonymous-intersection> ;\r
-\r
-: (class-and) ( first second -- class )\r
- {\r
- { [ 2dup class<= ] [ drop ] }\r
- { [ 2dup swap class<= ] [ nip ] }\r
- { [ 2dup classes-intersect? not ] [ 2drop null ] }\r
- [\r
- [ normalize-class ] bi@ {\r
- { [ dup anonymous-union? ] [ anonymous-union-and ] }\r
- { [ dup anonymous-intersection? ] [ anonymous-intersection-and ] }\r
- { [ over anonymous-union? ] [ swap anonymous-union-and ] }\r
- { [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] }\r
- [ 2array <anonymous-intersection> ]\r
- } cond\r
- ]\r
- } cond ;\r
-\r
-: anonymous-union-or ( first second -- class )\r
- members>> swap suffix <anonymous-union> ;\r
-\r
-: ((class-or)) ( first second -- class )\r
- [ normalize-class ] bi@ {\r
- { [ dup anonymous-union? ] [ anonymous-union-or ] }\r
- { [ over anonymous-union? ] [ swap anonymous-union-or ] }\r
- [ 2array <anonymous-union> ]\r
- } cond ;\r
-\r
-: anonymous-complement-or ( first second -- class )\r
- 2dup class>> swap class<= [ 2drop object ] [ ((class-or)) ] if ;\r
-\r
-: (class-or) ( first second -- class )\r
- {\r
- { [ 2dup class<= ] [ nip ] }\r
- { [ 2dup swap class<= ] [ drop ] }\r
- { [ dup anonymous-complement? ] [ anonymous-complement-or ] }\r
- { [ over anonymous-complement? ] [ swap anonymous-complement-or ] }\r
- [ ((class-or)) ]\r
- } cond ;\r
-\r
-: (class-not) ( class -- complement )\r
- {\r
- { [ dup anonymous-complement? ] [ class>> ] }\r
- { [ dup object eq? ] [ drop null ] }\r
- { [ dup null eq? ] [ drop object ] }\r
- [ <anonymous-complement> ]\r
- } cond ;\r
-\r
-M: anonymous-union (flatten-class)\r
- members>> [ (flatten-class) ] each ;\r
-\r
-PRIVATE>\r
-\r
-ERROR: topological-sort-failed ;\r
-\r
-: largest-class ( seq -- n elt )\r
- dup [ [ class< ] with any? not ] curry find-last\r
- [ topological-sort-failed ] unless* ;\r
-\r
-: sort-classes ( seq -- newseq )\r
- [ name>> ] sort-with >vector\r
- [ dup empty? not ]\r
- [ dup largest-class [ swap remove-nth! ] dip ]\r
- produce nip ;\r
-\r
-: smallest-class ( classes -- class/f )\r
- [ f ] [\r
- natural-sort <reversed>\r
- [ ] [ [ class<= ] most ] map-reduce\r
- ] if-empty ;\r
-\r
-: flatten-class ( class -- assoc )\r
- [ (flatten-class) ] H{ } make-assoc ;\r
+! Copyright (C) 2004, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel classes combinators accessors sequences arrays
+vectors assocs namespaces words sorting layouts math hashtables
+kernel.private sets math.order ;
+IN: classes.algebra
+
+<PRIVATE
+
+TUPLE: anonymous-union { members read-only } ;
+
+: <anonymous-union> ( members -- class )
+ [ null eq? not ] filter prune
+ dup length 1 = [ first ] [ anonymous-union boa ] if ;
+
+TUPLE: anonymous-intersection { participants read-only } ;
+
+: <anonymous-intersection> ( participants -- class )
+ prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ;
+
+TUPLE: anonymous-complement { class read-only } ;
+
+C: <anonymous-complement> anonymous-complement
+
+DEFER: (class<=)
+
+DEFER: (class-not)
+
+GENERIC: (classes-intersect?) ( first second -- ? )
+
+DEFER: (class-and)
+
+DEFER: (class-or)
+
+GENERIC: (flatten-class) ( class -- )
+
+GENERIC: normalize-class ( class -- class' )
+
+M: object normalize-class ;
+
+PRIVATE>
+
+GENERIC: classoid? ( obj -- ? )
+
+M: word classoid? class? ;
+M: anonymous-union classoid? members>> [ classoid? ] all? ;
+M: anonymous-intersection classoid? participants>> [ classoid? ] all? ;
+M: anonymous-complement classoid? class>> classoid? ;
+
+: class<= ( first second -- ? )
+ class<=-cache get [ (class<=) ] 2cache ;
+
+: class< ( first second -- ? )
+ {
+ { [ 2dup class<= not ] [ 2drop f ] }
+ { [ 2dup swap class<= not ] [ 2drop t ] }
+ [ [ rank-class ] bi@ < ]
+ } cond ;
+
+: class<=> ( first second -- ? )
+ {
+ { [ 2dup class<= not ] [ 2drop +gt+ ] }
+ { [ 2dup swap class<= not ] [ 2drop +lt+ ] }
+ [ [ rank-class ] bi@ <=> ]
+ } cond ;
+
+: class= ( first second -- ? )
+ [ class<= ] [ swap class<= ] 2bi and ;
+
+: class-not ( class -- complement )
+ class-not-cache get [ (class-not) ] cache ;
+
+: classes-intersect? ( first second -- ? )
+ classes-intersect-cache get [
+ normalize-class (classes-intersect?)
+ ] 2cache ;
+
+: class-and ( first second -- class )
+ class-and-cache get [ (class-and) ] 2cache ;
+
+: class-or ( first second -- class )
+ class-or-cache get [ (class-or) ] 2cache ;
+
+<PRIVATE
+
+: superclass<= ( first second -- ? )
+ swap superclass dup [ swap class<= ] [ 2drop f ] if ;
+
+: left-anonymous-union<= ( first second -- ? )
+ [ members>> ] dip [ class<= ] curry all? ;
+
+: right-union<= ( first second -- ? )
+ members [ class<= ] with any? ;
+
+: right-anonymous-union<= ( first second -- ? )
+ members>> [ class<= ] with any? ;
+
+: left-anonymous-intersection<= ( first second -- ? )
+ [ participants>> ] dip [ class<= ] curry any? ;
+
+: right-anonymous-intersection<= ( first second -- ? )
+ participants>> [ class<= ] with all? ;
+
+: anonymous-complement<= ( first second -- ? )
+ [ class>> ] bi@ swap class<= ;
+
+: normalize-complement ( class -- class' )
+ class>> normalize-class {
+ { [ dup anonymous-union? ] [
+ members>>
+ [ class-not normalize-class ] map
+ <anonymous-intersection>
+ ] }
+ { [ dup anonymous-intersection? ] [
+ participants>>
+ [ class-not normalize-class ] map
+ <anonymous-union>
+ ] }
+ [ drop object ]
+ } cond ;
+
+: left-anonymous-complement<= ( first second -- ? )
+ [ normalize-complement ] dip class<= ;
+
+PREDICATE: nontrivial-anonymous-complement < anonymous-complement
+ class>> {
+ [ anonymous-union? ]
+ [ anonymous-intersection? ]
+ [ members ]
+ [ participants ]
+ } cleave or or or ;
+
+PREDICATE: empty-union < anonymous-union members>> empty? ;
+
+PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
+
+: (class<=) ( first second -- ? )
+ 2dup eq? [ 2drop t ] [
+ [ normalize-class ] bi@
+ 2dup superclass<= [ 2drop t ] [
+ {
+ { [ 2dup eq? ] [ 2drop t ] }
+ { [ dup empty-intersection? ] [ 2drop t ] }
+ { [ over empty-union? ] [ 2drop t ] }
+ { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
+ { [ over anonymous-union? ] [ left-anonymous-union<= ] }
+ { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
+ { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
+ { [ dup members ] [ right-union<= ] }
+ { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
+ { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
+ { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
+ [ 2drop f ]
+ } cond
+ ] if
+ ] if ;
+
+M: anonymous-union (classes-intersect?)
+ members>> [ classes-intersect? ] with any? ;
+
+M: anonymous-intersection (classes-intersect?)
+ participants>> [ classes-intersect? ] with all? ;
+
+M: anonymous-complement (classes-intersect?)
+ class>> class<= not ;
+
+: anonymous-union-and ( first second -- class )
+ members>> [ class-and ] with map <anonymous-union> ;
+
+: anonymous-intersection-and ( first second -- class )
+ participants>> swap suffix <anonymous-intersection> ;
+
+: (class-and) ( first second -- class )
+ {
+ { [ 2dup class<= ] [ drop ] }
+ { [ 2dup swap class<= ] [ nip ] }
+ { [ 2dup classes-intersect? not ] [ 2drop null ] }
+ [
+ [ normalize-class ] bi@ {
+ { [ dup anonymous-union? ] [ anonymous-union-and ] }
+ { [ dup anonymous-intersection? ] [ anonymous-intersection-and ] }
+ { [ over anonymous-union? ] [ swap anonymous-union-and ] }
+ { [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] }
+ [ 2array <anonymous-intersection> ]
+ } cond
+ ]
+ } cond ;
+
+: anonymous-union-or ( first second -- class )
+ members>> swap suffix <anonymous-union> ;
+
+: ((class-or)) ( first second -- class )
+ [ normalize-class ] bi@ {
+ { [ dup anonymous-union? ] [ anonymous-union-or ] }
+ { [ over anonymous-union? ] [ swap anonymous-union-or ] }
+ [ 2array <anonymous-union> ]
+ } cond ;
+
+: anonymous-complement-or ( first second -- class )
+ 2dup class>> swap class<= [ 2drop object ] [ ((class-or)) ] if ;
+
+: (class-or) ( first second -- class )
+ {
+ { [ 2dup class<= ] [ nip ] }
+ { [ 2dup swap class<= ] [ drop ] }
+ { [ dup anonymous-complement? ] [ anonymous-complement-or ] }
+ { [ over anonymous-complement? ] [ swap anonymous-complement-or ] }
+ [ ((class-or)) ]
+ } cond ;
+
+: (class-not) ( class -- complement )
+ {
+ { [ dup anonymous-complement? ] [ class>> ] }
+ { [ dup object eq? ] [ drop null ] }
+ { [ dup null eq? ] [ drop object ] }
+ [ <anonymous-complement> ]
+ } cond ;
+
+M: anonymous-union (flatten-class)
+ members>> [ (flatten-class) ] each ;
+
+PRIVATE>
+
+ERROR: topological-sort-failed ;
+
+: largest-class ( seq -- n elt )
+ dup [ [ class< ] with any? not ] curry find-last
+ [ topological-sort-failed ] unless* ;
+
+: sort-classes ( seq -- newseq )
+ [ name>> ] sort-with >vector
+ [ dup empty? not ]
+ [ dup largest-class [ swap remove-nth! ] dip ]
+ produce nip ;
+
+: smallest-class ( classes -- class/f )
+ [ f ] [
+ natural-sort <reversed>
+ [ ] [ [ class<= ] most ] map-reduce
+ ] if-empty ;
+
+: flatten-class ( class -- assoc )
+ [ (flatten-class) ] H{ } make-assoc ;
-USING: help.markup help.syntax kernel kernel.private\r
-continuations.private vectors arrays namespaces\r
-assocs words quotations lexer sequences math ;\r
-IN: continuations\r
-\r
-ARTICLE: "errors-restartable" "Restartable errors"\r
-"Support for restartable errors is built on top of the basic error handling facility. The following words signals recoverable errors:"\r
-{ $subsections\r
- throw-restarts\r
- rethrow-restarts\r
-}\r
-"The list of restarts from the most recently-thrown error is stored in a global variable:"\r
-{ $subsections restarts }\r
-"To invoke restarts, see " { $link "debugger" } "." ;\r
-\r
-ARTICLE: "errors-post-mortem" "Post-mortem error inspection"\r
-"The most recently thrown error, together with the continuation at that point, are stored in a pair of global variables:"\r
-{ $subsections\r
- error\r
- error-continuation\r
-}\r
-"Developer tools for inspecting these values are found in " { $link "debugger" } "." ;\r
-\r
-ARTICLE: "errors-anti-examples" "Common error handling pitfalls"\r
-"When used correctly, exception handling can lead to more robust code with less duplication of error handling logic. However, there are some pitfalls to keep in mind."\r
-{ $heading "Anti-pattern #1: Ignoring errors" }\r
-"The " { $link ignore-errors } " word should almost never be used. Ignoring errors does not make code more robust and in fact makes it much harder to debug if an intermittent error does show up when the code is run under previously unforseen circumstances. Never ignore unexpected errors; always report them to the user."\r
-{ $heading "Anti-pattern #2: Catching errors too early" }\r
-"A less severe form of the previous anti-pattern is code that makes overly zealous use of " { $link recover } ". It is almost always a mistake to catch an error, log a message, and keep going. The only exception is network servers and other long-running processes that must remain running even if individual tasks fail. In these cases, place the " { $link recover } " as high up in the call stack as possible."\r
-$nl\r
-"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically."\r
-{ $heading "Anti-pattern #3: Dropping and rethrowing" }\r
-"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught."\r
-{ $heading "Anti-pattern #4: Logging and rethrowing" }\r
-"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ;\r
-\r
-ARTICLE: "errors" "Exception handling"\r
-"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."\r
-$nl\r
-"Two words raise an error in the innermost error handler for the current dynamic extent:"\r
-{ $subsections\r
- throw\r
- rethrow\r
-}\r
-"Words for establishing an error handler:"\r
-{ $subsections\r
- cleanup\r
- recover\r
- ignore-errors\r
-}\r
-"Syntax sugar for defining errors:"\r
-{ $subsections POSTPONE: ERROR: }\r
-"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."\r
-{ $subsections\r
- "errors-restartable"\r
- "debugger"\r
- "errors-post-mortem"\r
- "errors-anti-examples"\r
-}\r
-"When Factor encouters a critical error, it calls the following word:"\r
-{ $subsections die } ;\r
-\r
-ARTICLE: "continuations.private" "Continuation implementation details"\r
-"A continuation is simply a tuple holding the contents of the five stacks:"\r
-{ $subsections\r
- continuation\r
- >continuation<\r
-}\r
-"The five stacks can be read and written:"\r
-{ $subsections\r
- datastack\r
- set-datastack\r
- retainstack\r
- set-retainstack\r
- callstack\r
- set-callstack\r
- namestack\r
- set-namestack\r
- catchstack\r
- set-catchstack\r
-} ;\r
-\r
-ARTICLE: "continuations" "Continuations"\r
-"At any point in the execution of a program, the " { $emphasis "current continuation" } " represents the future of the computation."\r
-$nl\r
-"Words for working with continuations are found in the " { $vocab-link "continuations" } " vocabulary; implementation details are in " { $vocab-link "continuations.private" } "."\r
-$nl\r
-"Continuations can be reified with the following two words:"\r
-{ $subsections\r
- callcc0\r
- callcc1\r
-}\r
-"Another two words resume continuations:"\r
-{ $subsections\r
- continue\r
- continue-with\r
-}\r
-"Continuations as control-flow:"\r
-{ $subsections\r
- attempt-all\r
- with-return\r
-}\r
-"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."\r
-{ $subsections "continuations.private" } ;\r
-\r
-ABOUT: "continuations"\r
-\r
-HELP: catchstack*\r
-{ $values { "catchstack" "a vector of continuations" } }\r
-{ $description "Outputs the current catchstack." } ;\r
-\r
-HELP: catchstack\r
-{ $values { "catchstack" "a vector of continuations" } }\r
-{ $description "Outputs a copy of the current catchstack." } ;\r
-\r
-HELP: set-catchstack\r
-{ $values { "catchstack" "a vector of continuations" } }\r
-{ $description "Replaces the catchstack with a copy of the given vector." } ;\r
-\r
-HELP: continuation\r
-{ $values { "continuation" continuation } }\r
-{ $description "Reifies the current continuation from the point immediately after which the caller returns." } ;\r
-\r
-HELP: >continuation<\r
-{ $values { "continuation" continuation } { "data" vector } { "call" vector } { "retain" vector } { "name" vector } { "catch" vector } }\r
-{ $description "Takes a continuation apart into its constituents." } ;\r
-\r
-HELP: ifcc\r
-{ $values { "capture" { $quotation "( continuation -- )" } } { "restore" quotation } }\r
-{ $description "Reifies a continuation from the point immediately after which this word returns, and passes it to " { $snippet "capture" } ". When the continuation is restored, execution resumes and "{ $snippet "restore" } " is called." } ;\r
-\r
-{ callcc0 continue callcc1 continue-with ifcc } related-words\r
-\r
-HELP: callcc0\r
-{ $values { "quot" { $quotation "( continuation -- )" } } }\r
-{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue } " word resumes the continuation." } ;\r
-\r
-HELP: callcc1\r
-{ $values { "quot" { $quotation "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } }\r
-{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ;\r
-\r
-HELP: continue\r
-{ $values { "continuation" continuation } }\r
-{ $description "Resumes a continuation reified by " { $link callcc0 } "." } ;\r
-\r
-HELP: continue-with\r
-{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } }\r
-{ $description "Resumes a continuation reified by " { $link callcc1 } ". The object will be placed on the data stack when the continuation resumes." } ;\r
-\r
-HELP: error\r
-{ $description "Global variable holding most recently thrown error." }\r
-{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;\r
-\r
-HELP: error-continuation\r
-{ $description "Global variable holding current continuation of most recently thrown error." }\r
-{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;\r
-\r
-HELP: restarts\r
-{ $var-description "Global variable holding the set of possible restarts for the most recently thrown error." }\r
-{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;\r
-\r
-HELP: >c\r
-{ $values { "continuation" continuation } }\r
-{ $description "Pushes an exception handler continuation on the catch stack. The continuation must have been reified by " { $link callcc1 } "." } ;\r
-\r
-HELP: c>\r
-{ $values { "continuation" continuation } }\r
-{ $description "Pops an exception handler continuation from the catch stack." } ;\r
-\r
-HELP: throw\r
-{ $values { "error" object } }\r
-{ $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ;\r
-\r
-{ cleanup recover } related-words\r
-\r
-HELP: cleanup\r
-{ $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } }\r
-{ $description "Calls the " { $snippet "try" } " quotation. If no error is thrown, calls " { $snippet "cleanup-always" } " without restoring the data stack. If an error is thrown, restores the data stack, calls " { $snippet "cleanup-always" } " followed by " { $snippet "cleanup-error" } ", and rethrows the error." } ;\r
-\r
-HELP: recover\r
-{ $values { "try" quotation } { "recovery" { $quotation "( error -- )" } } }\r
-{ $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ;\r
-\r
-HELP: ignore-errors\r
-{ $values { "quot" quotation } }\r
-{ $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ;\r
-\r
-HELP: rethrow\r
-{ $values { "error" object } }\r
-{ $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." }\r
-{ $notes\r
- "This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler."\r
-}\r
-{ $examples\r
- "The " { $link with-lexer } " word catches errors, annotates them with the current line and column number, and rethrows them:"\r
- { $see with-lexer }\r
-} ;\r
-\r
-HELP: throw-restarts\r
-{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }\r
-{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." }\r
-{ $examples\r
- "Try invoking one of the two restarts which are offered after the below code throws an error:"\r
- { $code\r
- ": restart-test"\r
- " \"Oops!\" { { \"One\" 1 } { \"Two\" 2 } } condition"\r
- " \"You restarted: \" write . ;"\r
- "restart-test"\r
- }\r
-} ;\r
-\r
-HELP: rethrow-restarts\r
-{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }\r
-{ $description "Throws a restartable error using " { $link rethrow } ". Otherwise, this word is identical to " { $link throw-restarts } "." } ;\r
-\r
-{ throw rethrow throw-restarts rethrow-restarts } related-words\r
-\r
-HELP: compute-restarts\r
-{ $values { "error" object } { "seq" "a sequence" } }\r
-{ $description "Outputs a sequence of triples, where each triple consists of a human-readable string, an object, and a continuation. Resuming a continuation with the corresponding object restarts execution immediately after the corresponding call to " { $link condition } "."\r
-$nl\r
-"This word recursively travels up the delegation chain to collate restarts from nested and wrapped conditions." } ;\r
-\r
-HELP: save-error\r
-{ $values { "error" "an error" } }\r
-{ $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." }\r
-$low-level-note ;\r
-\r
-HELP: with-datastack\r
-{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } }\r
-{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." }\r
-{ $examples\r
- { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }\r
-} ;\r
-\r
-HELP: attempt-all\r
-{ $values\r
- { "seq" sequence } { "quot" quotation }\r
- { "obj" object } }\r
-{ $description "Applies the quotation to elements in a sequence and returns the value from the first quotation that does not throw an error. If all quotations throw an error, returns the last error thrown." }\r
-{ $examples "The first two numbers throw, the last one doesn't:"\r
- { $example\r
- "USING: prettyprint continuations kernel math ;"\r
- "{ 1 3 6 } [ dup odd? [ \"Odd\" throw ] when ] attempt-all ."\r
- "6" }\r
- "All quotations throw, the last exception is rethrown:"\r
- { $example\r
- "USING: prettyprint continuations kernel math ;"\r
- "[ { 1 3 5 } [ dup odd? [ throw ] when ] attempt-all ] [ ] recover ."\r
- "5"\r
- }\r
-} ;\r
-\r
-HELP: return\r
-{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ;\r
-\r
-HELP: with-return\r
-{ $values\r
- { "quot" quotation } }\r
-{ $description "Captures a continuation that can be reified by calling the " { $link return } " word. If so, it will resume execution immediatly after the " { $link with-return } " word. If " { $link return } " is not called, then execution proceeds as if this word were simply " { $link call } "." }\r
-{ $examples\r
- "Only \"Hi\" will print:"\r
- { $example\r
- "USING: prettyprint continuations io ;"\r
- "[ \"Hi\" print return \"Bye\" print ] with-return"\r
- "Hi"\r
-} } ;\r
-\r
-{ return with-return } related-words\r
-\r
-HELP: restart\r
-{ $values { "restart" restart } }\r
-{ $description "Invokes a restart." }\r
-{ $class-description "The class of restarts." } ;\r
+USING: help.markup help.syntax kernel kernel.private
+continuations.private vectors arrays namespaces
+assocs words quotations lexer sequences math ;
+IN: continuations
+
+ARTICLE: "errors-restartable" "Restartable errors"
+"Support for restartable errors is built on top of the basic error handling facility. The following words signals recoverable errors:"
+{ $subsections
+ throw-restarts
+ rethrow-restarts
+}
+"The list of restarts from the most recently-thrown error is stored in a global variable:"
+{ $subsections restarts }
+"To invoke restarts, see " { $link "debugger" } "." ;
+
+ARTICLE: "errors-post-mortem" "Post-mortem error inspection"
+"The most recently thrown error, together with the continuation at that point, are stored in a pair of global variables:"
+{ $subsections
+ error
+ error-continuation
+}
+"Developer tools for inspecting these values are found in " { $link "debugger" } "." ;
+
+ARTICLE: "errors-anti-examples" "Common error handling pitfalls"
+"When used correctly, exception handling can lead to more robust code with less duplication of error handling logic. However, there are some pitfalls to keep in mind."
+{ $heading "Anti-pattern #1: Ignoring errors" }
+"The " { $link ignore-errors } " word should almost never be used. Ignoring errors does not make code more robust and in fact makes it much harder to debug if an intermittent error does show up when the code is run under previously unforseen circumstances. Never ignore unexpected errors; always report them to the user."
+{ $heading "Anti-pattern #2: Catching errors too early" }
+"A less severe form of the previous anti-pattern is code that makes overly zealous use of " { $link recover } ". It is almost always a mistake to catch an error, log a message, and keep going. The only exception is network servers and other long-running processes that must remain running even if individual tasks fail. In these cases, place the " { $link recover } " as high up in the call stack as possible."
+$nl
+"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically."
+{ $heading "Anti-pattern #3: Dropping and rethrowing" }
+"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught."
+{ $heading "Anti-pattern #4: Logging and rethrowing" }
+"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ;
+
+ARTICLE: "errors" "Exception handling"
+"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."
+$nl
+"Two words raise an error in the innermost error handler for the current dynamic extent:"
+{ $subsections
+ throw
+ rethrow
+}
+"Words for establishing an error handler:"
+{ $subsections
+ cleanup
+ recover
+ ignore-errors
+}
+"Syntax sugar for defining errors:"
+{ $subsections POSTPONE: ERROR: }
+"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
+{ $subsections
+ "errors-restartable"
+ "debugger"
+ "errors-post-mortem"
+ "errors-anti-examples"
+}
+"When Factor encouters a critical error, it calls the following word:"
+{ $subsections die } ;
+
+ARTICLE: "continuations.private" "Continuation implementation details"
+"A continuation is simply a tuple holding the contents of the five stacks:"
+{ $subsections
+ continuation
+ >continuation<
+}
+"The five stacks can be read and written:"
+{ $subsections
+ datastack
+ set-datastack
+ retainstack
+ set-retainstack
+ callstack
+ set-callstack
+ namestack
+ set-namestack
+ catchstack
+ set-catchstack
+} ;
+
+ARTICLE: "continuations" "Continuations"
+"At any point in the execution of a program, the " { $emphasis "current continuation" } " represents the future of the computation."
+$nl
+"Words for working with continuations are found in the " { $vocab-link "continuations" } " vocabulary; implementation details are in " { $vocab-link "continuations.private" } "."
+$nl
+"Continuations can be reified with the following two words:"
+{ $subsections
+ callcc0
+ callcc1
+}
+"Another two words resume continuations:"
+{ $subsections
+ continue
+ continue-with
+}
+"Continuations as control-flow:"
+{ $subsections
+ attempt-all
+ with-return
+}
+"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
+{ $subsections "continuations.private" } ;
+
+ABOUT: "continuations"
+
+HELP: catchstack*
+{ $values { "catchstack" "a vector of continuations" } }
+{ $description "Outputs the current catchstack." } ;
+
+HELP: catchstack
+{ $values { "catchstack" "a vector of continuations" } }
+{ $description "Outputs a copy of the current catchstack." } ;
+
+HELP: set-catchstack
+{ $values { "catchstack" "a vector of continuations" } }
+{ $description "Replaces the catchstack with a copy of the given vector." } ;
+
+HELP: continuation
+{ $values { "continuation" continuation } }
+{ $description "Reifies the current continuation from the point immediately after which the caller returns." } ;
+
+HELP: >continuation<
+{ $values { "continuation" continuation } { "data" vector } { "call" vector } { "retain" vector } { "name" vector } { "catch" vector } }
+{ $description "Takes a continuation apart into its constituents." } ;
+
+HELP: ifcc
+{ $values { "capture" { $quotation "( continuation -- )" } } { "restore" quotation } }
+{ $description "Reifies a continuation from the point immediately after which this word returns, and passes it to " { $snippet "capture" } ". When the continuation is restored, execution resumes and "{ $snippet "restore" } " is called." } ;
+
+{ callcc0 continue callcc1 continue-with ifcc } related-words
+
+HELP: callcc0
+{ $values { "quot" { $quotation "( continuation -- )" } } }
+{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue } " word resumes the continuation." } ;
+
+HELP: callcc1
+{ $values { "quot" { $quotation "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } }
+{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ;
+
+HELP: continue
+{ $values { "continuation" continuation } }
+{ $description "Resumes a continuation reified by " { $link callcc0 } "." } ;
+
+HELP: continue-with
+{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } }
+{ $description "Resumes a continuation reified by " { $link callcc1 } ". The object will be placed on the data stack when the continuation resumes." } ;
+
+HELP: error
+{ $description "Global variable holding most recently thrown error." }
+{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;
+
+HELP: error-continuation
+{ $description "Global variable holding current continuation of most recently thrown error." }
+{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;
+
+HELP: restarts
+{ $var-description "Global variable holding the set of possible restarts for the most recently thrown error." }
+{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;
+
+HELP: >c
+{ $values { "continuation" continuation } }
+{ $description "Pushes an exception handler continuation on the catch stack. The continuation must have been reified by " { $link callcc1 } "." } ;
+
+HELP: c>
+{ $values { "continuation" continuation } }
+{ $description "Pops an exception handler continuation from the catch stack." } ;
+
+HELP: throw
+{ $values { "error" object } }
+{ $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ;
+
+{ cleanup recover } related-words
+
+HELP: cleanup
+{ $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } }
+{ $description "Calls the " { $snippet "try" } " quotation. If no error is thrown, calls " { $snippet "cleanup-always" } " without restoring the data stack. If an error is thrown, restores the data stack, calls " { $snippet "cleanup-always" } " followed by " { $snippet "cleanup-error" } ", and rethrows the error." } ;
+
+HELP: recover
+{ $values { "try" quotation } { "recovery" { $quotation "( error -- )" } } }
+{ $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ;
+
+HELP: ignore-errors
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ;
+
+HELP: rethrow
+{ $values { "error" object } }
+{ $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." }
+{ $notes
+ "This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler."
+}
+{ $examples
+ "The " { $link with-lexer } " word catches errors, annotates them with the current line and column number, and rethrows them:"
+ { $see with-lexer }
+} ;
+
+HELP: throw-restarts
+{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
+{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." }
+{ $examples
+ "Try invoking one of the two restarts which are offered after the below code throws an error:"
+ { $code
+ ": restart-test"
+ " \"Oops!\" { { \"One\" 1 } { \"Two\" 2 } } condition"
+ " \"You restarted: \" write . ;"
+ "restart-test"
+ }
+} ;
+
+HELP: rethrow-restarts
+{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
+{ $description "Throws a restartable error using " { $link rethrow } ". Otherwise, this word is identical to " { $link throw-restarts } "." } ;
+
+{ throw rethrow throw-restarts rethrow-restarts } related-words
+
+HELP: compute-restarts
+{ $values { "error" object } { "seq" "a sequence" } }
+{ $description "Outputs a sequence of triples, where each triple consists of a human-readable string, an object, and a continuation. Resuming a continuation with the corresponding object restarts execution immediately after the corresponding call to " { $link condition } "."
+$nl
+"This word recursively travels up the delegation chain to collate restarts from nested and wrapped conditions." } ;
+
+HELP: save-error
+{ $values { "error" "an error" } }
+{ $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." }
+$low-level-note ;
+
+HELP: with-datastack
+{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } }
+{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." }
+{ $examples
+ { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
+} ;
+
+HELP: attempt-all
+{ $values
+ { "seq" sequence } { "quot" quotation }
+ { "obj" object } }
+{ $description "Applies the quotation to elements in a sequence and returns the value from the first quotation that does not throw an error. If all quotations throw an error, returns the last error thrown." }
+{ $examples "The first two numbers throw, the last one doesn't:"
+ { $example
+ "USING: prettyprint continuations kernel math ;"
+ "{ 1 3 6 } [ dup odd? [ \"Odd\" throw ] when ] attempt-all ."
+ "6" }
+ "All quotations throw, the last exception is rethrown:"
+ { $example
+ "USING: prettyprint continuations kernel math ;"
+ "[ { 1 3 5 } [ dup odd? [ throw ] when ] attempt-all ] [ ] recover ."
+ "5"
+ }
+} ;
+
+HELP: return
+{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ;
+
+HELP: with-return
+{ $values
+ { "quot" quotation } }
+{ $description "Captures a continuation that can be reified by calling the " { $link return } " word. If so, it will resume execution immediatly after the " { $link with-return } " word. If " { $link return } " is not called, then execution proceeds as if this word were simply " { $link call } "." }
+{ $examples
+ "Only \"Hi\" will print:"
+ { $example
+ "USING: prettyprint continuations io ;"
+ "[ \"Hi\" print return \"Bye\" print ] with-return"
+ "Hi"
+} } ;
+
+{ return with-return } related-words
+
+HELP: restart
+{ $values { "restart" restart } }
+{ $description "Invokes a restart." }
+{ $class-description "The class of restarts." } ;
-USING: kernel math namespaces io tools.test sequences vectors\r
-continuations debugger parser memory arrays words\r
-kernel.private accessors eval ;\r
-IN: continuations.tests\r
-\r
-: (callcc1-test) ( n obj -- n' obj )\r
- [ 1 - dup ] dip ?push\r
- over 0 = [ "test-cc" get continue-with ] when\r
- (callcc1-test) ;\r
-\r
-: callcc1-test ( x -- list )\r
- [\r
- "test-cc" set V{ } clone (callcc1-test)\r
- ] callcc1 nip ;\r
-\r
-: callcc-namespace-test ( -- ? )\r
- [\r
- "test-cc" set\r
- 5 "x" set\r
- [\r
- 6 "x" set "test-cc" get continue\r
- ] with-scope\r
- ] callcc0 "x" get 5 = ;\r
-\r
-[ t ] [ 10 callcc1-test 10 iota reverse >vector = ] unit-test\r
-[ t ] [ callcc-namespace-test ] unit-test\r
-\r
-[ 5 throw ] [ 5 = ] must-fail-with\r
-\r
-[ t ] [\r
- [ "Hello" throw ] ignore-errors\r
- error get-global\r
- "Hello" =\r
-] unit-test\r
-\r
-"!!! The following error is part of the test" print\r
-\r
-[ ] [ [ 6 [ 12 [ "2 car" ] ] ] print-error ] unit-test\r
-\r
-"!!! The following error is part of the test" print\r
-\r
-[ ] [ [ [ "2 car" ] eval ] try ] unit-test\r
-\r
-[ f throw ] must-fail\r
-\r
-! Weird PowerPC bug.\r
-[ ] [\r
- [ "4" throw ] ignore-errors\r
- gc\r
- gc\r
-] unit-test\r
-\r
-! ! See how well callstack overflow is handled\r
-! [ clear drop ] must-fail\r
-! \r
-! : callstack-overflow callstack-overflow f ;\r
-! [ callstack-overflow ] must-fail\r
-\r
-: don't-compile-me ( -- ) ;\r
-: foo ( -- ) callstack "c" set don't-compile-me ;\r
-: bar ( -- a b ) 1 foo 2 ;\r
-\r
-<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >>\r
-\r
-[ 1 2 ] [ bar ] unit-test\r
-\r
-[ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test\r
-\r
-[ 1 ] [ "c" get innermost-frame-scan ] unit-test\r
-\r
-SYMBOL: always-counter\r
-SYMBOL: error-counter\r
-\r
-[\r
- 0 always-counter set\r
- 0 error-counter set\r
-\r
- [ ] [ always-counter inc ] [ error-counter inc ] cleanup\r
-\r
- [ 1 ] [ always-counter get ] unit-test\r
- [ 0 ] [ error-counter get ] unit-test\r
-\r
- [\r
- [ "a" throw ]\r
- [ always-counter inc ]\r
- [ error-counter inc ] cleanup\r
- ] [ "a" = ] must-fail-with\r
-\r
- [ 2 ] [ always-counter get ] unit-test\r
- [ 1 ] [ error-counter get ] unit-test\r
-\r
- [\r
- [ ]\r
- [ always-counter inc "a" throw ]\r
- [ error-counter inc ] cleanup\r
- ] [ "a" = ] must-fail-with\r
-\r
- [ 3 ] [ always-counter get ] unit-test\r
- [ 1 ] [ error-counter get ] unit-test\r
-] with-scope\r
-\r
-[ ] [ [ return ] with-return ] unit-test\r
-\r
-[ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with\r
-\r
-[ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test\r
-\r
-[ with-datastack ] must-infer\r
+USING: kernel math namespaces io tools.test sequences vectors
+continuations debugger parser memory arrays words
+kernel.private accessors eval ;
+IN: continuations.tests
+
+: (callcc1-test) ( n obj -- n' obj )
+ [ 1 - dup ] dip ?push
+ over 0 = [ "test-cc" get continue-with ] when
+ (callcc1-test) ;
+
+: callcc1-test ( x -- list )
+ [
+ "test-cc" set V{ } clone (callcc1-test)
+ ] callcc1 nip ;
+
+: callcc-namespace-test ( -- ? )
+ [
+ "test-cc" set
+ 5 "x" set
+ [
+ 6 "x" set "test-cc" get continue
+ ] with-scope
+ ] callcc0 "x" get 5 = ;
+
+[ t ] [ 10 callcc1-test 10 iota reverse >vector = ] unit-test
+[ t ] [ callcc-namespace-test ] unit-test
+
+[ 5 throw ] [ 5 = ] must-fail-with
+
+[ t ] [
+ [ "Hello" throw ] ignore-errors
+ error get-global
+ "Hello" =
+] unit-test
+
+"!!! The following error is part of the test" print
+
+[ ] [ [ 6 [ 12 [ "2 car" ] ] ] print-error ] unit-test
+
+"!!! The following error is part of the test" print
+
+[ ] [ [ [ "2 car" ] eval ] try ] unit-test
+
+[ f throw ] must-fail
+
+! Weird PowerPC bug.
+[ ] [
+ [ "4" throw ] ignore-errors
+ gc
+ gc
+] unit-test
+
+! ! See how well callstack overflow is handled
+! [ clear drop ] must-fail
+!
+! : callstack-overflow callstack-overflow f ;
+! [ callstack-overflow ] must-fail
+
+: don't-compile-me ( -- ) ;
+: foo ( -- ) callstack "c" set don't-compile-me ;
+: bar ( -- a b ) 1 foo 2 ;
+
+<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >>
+
+[ 1 2 ] [ bar ] unit-test
+
+[ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test
+
+[ 1 ] [ "c" get innermost-frame-scan ] unit-test
+
+SYMBOL: always-counter
+SYMBOL: error-counter
+
+[
+ 0 always-counter set
+ 0 error-counter set
+
+ [ ] [ always-counter inc ] [ error-counter inc ] cleanup
+
+ [ 1 ] [ always-counter get ] unit-test
+ [ 0 ] [ error-counter get ] unit-test
+
+ [
+ [ "a" throw ]
+ [ always-counter inc ]
+ [ error-counter inc ] cleanup
+ ] [ "a" = ] must-fail-with
+
+ [ 2 ] [ always-counter get ] unit-test
+ [ 1 ] [ error-counter get ] unit-test
+
+ [
+ [ ]
+ [ always-counter inc "a" throw ]
+ [ error-counter inc ] cleanup
+ ] [ "a" = ] must-fail-with
+
+ [ 3 ] [ always-counter get ] unit-test
+ [ 1 ] [ error-counter get ] unit-test
+] with-scope
+
+[ ] [ [ return ] with-return ] unit-test
+
+[ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with
+
+[ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test
+
+[ with-datastack ] must-infer
"MEMO" "MEMO:" "METHOD"
"SYNTAX"
"PREDICATE" "PRIMITIVE"
+ "STRUCT" "TAG" "TUPLE" "UNION-STRUCT"
"UNION"))
(defconst fuel-syntax--no-indent-def-starts '("ARTICLE"
"HELP"
"SINGLETONS"
"SYMBOLS"
- "TUPLE"
"VARS"))
(defconst fuel-syntax--indent-def-start-regex
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.syntax help.markup threads ;\r
-\r
-IN: odbc\r
-\r
-HELP: odbc-init \r
-{ $values { "env" "an ODBC environment handle" } } \r
-{ $description \r
- "Initializes the ODBC driver manager and returns the " \r
- "environment handle required by " { $link odbc-connect } "."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-connect \r
-{ $values { "env" "an ODBC environment handle" } { "dsn" "a string" } { "dbc" "an ODBC database connection handle" } } \r
-{ $description \r
- "Connects to the database identified by the ODBC data source name (DSN). " \r
- "The environment handle is usually obtained by a call to " { $link odbc-init } ". The result is the ODBC connection handle which can be used in other ODBC calls. When finished with the connection handle " { $link odbc-disconnect } " must be called on it."\r
-} \r
-{ $examples { $code "dbc get \"DSN=mydsn\" odbc-connect" } }\r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-disconnect \r
-{ $values { "dbc" "an ODBC database connection handle" } } \r
-{ $description \r
- "Disconnects from the given database." \r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-prepare\r
-{ $values { "dbc" "an ODBC database connection handle" } { "string" "a string containing SQL" } { "statement" "an ODBC statement handle" } } \r
-{ $description \r
- "Prepares (precompiles) the given SQL string, ready for execution with " { $link odbc-execute } ". When finished with the statement " { $link odbc-free-statement } " must be called on it." \r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-free-statement\r
-{ $values { "statement" "an ODBC statement handle" } } \r
-{ $description \r
- "Closes the statement handle and frees up all resources associated with it." \r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-execute\r
-{ $values { "statement" "an ODBC statement handle" } } \r
-{ $description \r
- "Executes the statement. Once this is done " { $link odbc-next-row } " can be called to retrieve rows." \r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-next-row\r
-{ $values { "statement" "an ODBC statement handle" } { "bool" "a boolean indicating success or failure" } } \r
-{ $description \r
- "Retrieves the next available row from the database. If no next row is available then " { $link f } " is returned. Once the row is retrieved " { $link odbc-number-of-columns } ", " { $link odbc-describe-column } ", " { $link odbc-get-field } " and " { $link odbc-get-row-fields } " can be used to query the data retrieved." \r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-number-of-columns\r
-{ $values { "statement" "an ODBC statement handle" } { "number" "a number" } } \r
-{ $description \r
- "Returns the number of columns of data retrieved."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-describe-column\r
-{ $values { "statement" "an ODBC statement handle" } { "n" "a column number starting from one" } { "column" "a column object" } } \r
-{ $description \r
- "Retrieves column information for the given column number from the statement. The column number must be one or greater. The " { $link <column> } " object returned provides data type, name, etc."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-get-field\r
-{ $values { "statement" "an ODBC statement handle" } { "column" "a column number starting from one or a <column> object" } { "field" "a <field> object" } } \r
-{ $description \r
- "Returns a field object which contains the data for the field in the given column in the current row. The column can be identified by a number or a <column> object. The datatype of the contents of the field depends on the type of the column itself. Note that this word can only be safely called once on each column in a given row with most ODBC drivers. Subsequent calls on the same row for the same column can fail."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-get-row-fields\r
-{ $values { "statement" "an ODBC statement handle" } { "seq" "a sequence" } } \r
-{ $description \r
- "Returns a sequence of all field data for the current row. Note that this isnot the <field> objects, but the data for that field. This word can only be called once on a given row. Subsequent calls on the same row may fail on some ODBC drivers."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-get-all-rows\r
-{ $values { "statement" "an ODBC statement handle" } { "seq" "a sequence" } } \r
-{ $description \r
- "Returns a sequence of all rows available from the statement. Effectively it is the contents of the entire query so may take some time and memory. Each element of the sequence is itself a sequence containing the data for that row. A " { $link yield } " is performed an various intervals so as to not lock up the Factor instance while it is running."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-query\r
-{ $values { "string" "a string containing SQL" } { "dsn" "a DSN string" } { "result" "a sequence" } } \r
-{ $description \r
- "This word initializes odbc, connects to the database with the given DSN, executes the query string and returns the result as a sequence. It cleans up all resources it uses. It is an inefficient way of running multiple queries but is useful for the occasional query, testing at the REPL, or as an example of how to do it."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup threads ;
+
+IN: odbc
+
+HELP: odbc-init
+{ $values { "env" "an ODBC environment handle" } }
+{ $description
+ "Initializes the ODBC driver manager and returns the "
+ "environment handle required by " { $link odbc-connect } "."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-connect
+{ $values { "env" "an ODBC environment handle" } { "dsn" "a string" } { "dbc" "an ODBC database connection handle" } }
+{ $description
+ "Connects to the database identified by the ODBC data source name (DSN). "
+ "The environment handle is usually obtained by a call to " { $link odbc-init } ". The result is the ODBC connection handle which can be used in other ODBC calls. When finished with the connection handle " { $link odbc-disconnect } " must be called on it."
+}
+{ $examples { $code "dbc get \"DSN=mydsn\" odbc-connect" } }
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-disconnect
+{ $values { "dbc" "an ODBC database connection handle" } }
+{ $description
+ "Disconnects from the given database."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-prepare
+{ $values { "dbc" "an ODBC database connection handle" } { "string" "a string containing SQL" } { "statement" "an ODBC statement handle" } }
+{ $description
+ "Prepares (precompiles) the given SQL string, ready for execution with " { $link odbc-execute } ". When finished with the statement " { $link odbc-free-statement } " must be called on it."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-free-statement
+{ $values { "statement" "an ODBC statement handle" } }
+{ $description
+ "Closes the statement handle and frees up all resources associated with it."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-execute
+{ $values { "statement" "an ODBC statement handle" } }
+{ $description
+ "Executes the statement. Once this is done " { $link odbc-next-row } " can be called to retrieve rows."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-next-row
+{ $values { "statement" "an ODBC statement handle" } { "bool" "a boolean indicating success or failure" } }
+{ $description
+ "Retrieves the next available row from the database. If no next row is available then " { $link f } " is returned. Once the row is retrieved " { $link odbc-number-of-columns } ", " { $link odbc-describe-column } ", " { $link odbc-get-field } " and " { $link odbc-get-row-fields } " can be used to query the data retrieved."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-number-of-columns
+{ $values { "statement" "an ODBC statement handle" } { "number" "a number" } }
+{ $description
+ "Returns the number of columns of data retrieved."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-describe-column
+{ $values { "statement" "an ODBC statement handle" } { "n" "a column number starting from one" } { "column" "a column object" } }
+{ $description
+ "Retrieves column information for the given column number from the statement. The column number must be one or greater. The " { $link <column> } " object returned provides data type, name, etc."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-get-field
+{ $values { "statement" "an ODBC statement handle" } { "column" "a column number starting from one or a <column> object" } { "field" "a <field> object" } }
+{ $description
+ "Returns a field object which contains the data for the field in the given column in the current row. The column can be identified by a number or a <column> object. The datatype of the contents of the field depends on the type of the column itself. Note that this word can only be safely called once on each column in a given row with most ODBC drivers. Subsequent calls on the same row for the same column can fail."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-get-row-fields
+{ $values { "statement" "an ODBC statement handle" } { "seq" "a sequence" } }
+{ $description
+ "Returns a sequence of all field data for the current row. Note that this isnot the <field> objects, but the data for that field. This word can only be called once on a given row. Subsequent calls on the same row may fail on some ODBC drivers."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-get-all-rows
+{ $values { "statement" "an ODBC statement handle" } { "seq" "a sequence" } }
+{ $description
+ "Returns a sequence of all rows available from the statement. Effectively it is the contents of the entire query so may take some time and memory. Each element of the sequence is itself a sequence containing the data for that row. A " { $link yield } " is performed an various intervals so as to not lock up the Factor instance while it is running."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-query
+{ $values { "string" "a string containing SQL" } { "dsn" "a DSN string" } { "result" "a sequence" } }
+{ $description
+ "This word initializes odbc, connects to the database with the given DSN, executes the query string and returns the result as a sequence. It cleans up all resources it uses. It is an inefficient way of running multiple queries but is useful for the occasional query, testing at the REPL, or as an example of how to do it."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-!\r
-! TODO:\r
-! based on number of channels in file.\r
-! - End of decoding is indicated by an exception when reading the stream.\r
-! How to work around this? C player example uses feof but streams don't\r
-! have that in Factor.\r
-! - Work out openal buffer method that plays nicely with streaming over\r
-! slow connections.\r
-! - Have start/stop/seek methods on the player object.\r
-!\r
-USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays\r
- sequences libc shuffle alien.c-types system openal math\r
- namespaces threads shuffle opengl arrays ui.gadgets.worlds\r
- combinators math.parser ui.gadgets ui.render opengl.gl ui\r
- continuations io.files hints combinators.lib sequences.lib\r
- io.encodings.binary debugger math.order accessors ;\r
-\r
-IN: ogg.player\r
-\r
-: audio-buffer-size ( -- number ) 128 1024 * ; inline\r
-\r
-TUPLE: player stream temp-state\r
- op oy og\r
- vo vi vd vb vc vorbis\r
- to ti tc td yuv rgb theora video-ready? video-time video-granulepos\r
- source buffers buffer-indexes start-time\r
- playing? audio-full? audio-index audio-buffer audio-granulepos\r
- gadget ;\r
-\r
-: init-vorbis ( player -- )\r
- dup oy>> ogg_sync_init drop\r
- dup vi>> vorbis_info_init\r
- vc>> vorbis_comment_init ;\r
-\r
-: init-theora ( player -- )\r
- dup ti>> theora_info_init\r
- tc>> theora_comment_init ;\r
-\r
-: init-sound ( player -- )\r
- init-openal check-error\r
- 1 gen-buffers check-error >>buffers\r
- 2 "uint" <c-array> >>buffer-indexes\r
- 1 gen-sources check-error first >>source drop ;\r
-\r
-: <player> ( stream -- player )\r
- player new\r
- swap >>stream\r
- 0 >>vorbis\r
- 0 >>theora\r
- 0 >>video-time\r
- 0 >>video-granulepos\r
- f >>video-ready?\r
- f >>audio-full?\r
- 0 >>audio-index\r
- 0 >>start-time\r
- audio-buffer-size "short" <c-array> >>audio-buffer\r
- 0 >>audio-granulepos\r
- f >>playing?\r
- "ogg_packet" malloc-object >>op\r
- "ogg_sync_state" malloc-object >>oy\r
- "ogg_page" malloc-object >>og\r
- "ogg_stream_state" malloc-object >>vo\r
- "vorbis_info" malloc-object >>vi\r
- "vorbis_dsp_state" malloc-object >>vd\r
- "vorbis_block" malloc-object >>vb\r
- "vorbis_comment" malloc-object >>vc\r
- "ogg_stream_state" malloc-object >>to\r
- "theora_info" malloc-object >>ti\r
- "theora_comment" malloc-object >>tc\r
- "theora_state" malloc-object >>td\r
- "yuv_buffer" <c-object> >>yuv\r
- "ogg_stream_state" <c-object> >>temp-state\r
- dup init-sound\r
- dup init-vorbis\r
- dup init-theora ;\r
-\r
-: num-channels ( player -- channels )\r
- vi>> vorbis_info-channels ;\r
-\r
-: al-channel-format ( player -- format )\r
- num-channels 1 = AL_FORMAT_MONO16 AL_FORMAT_STEREO16 ? ;\r
-\r
-: get-time ( player -- time )\r
- dup start-time>> zero? [\r
- millis >>start-time\r
- ] when\r
- start-time>> millis swap - 1000.0 /f ;\r
-\r
-: clamp ( n -- n )\r
- 255 min 0 max ; inline\r
-\r
-: stride ( line yuv -- uvy yy )\r
- [ yuv_buffer-uv_stride >fixnum swap 2/ * ] 2keep\r
- yuv_buffer-y_stride >fixnum * >fixnum ; inline\r
-\r
-: each-with4 ( obj obj obj obj seq quot -- )\r
- 4 each-withn ; inline\r
-\r
-: compute-y ( yuv uvy yy x -- y )\r
- + >fixnum nip swap yuv_buffer-y uchar-nth 16 - ; inline\r
-\r
-: compute-v ( yuv uvy yy x -- v )\r
- nip 2/ + >fixnum swap yuv_buffer-u uchar-nth 128 - ; inline\r
-\r
-: compute-u ( yuv uvy yy x -- v )\r
- nip 2/ + >fixnum swap yuv_buffer-v uchar-nth 128 - ; inline\r
-\r
-: compute-yuv ( yuv uvy yy x -- y u v )\r
- [ compute-y ] 4keep [ compute-u ] 4keep compute-v ; inline\r
-\r
-: compute-blue ( y u v -- b )\r
- drop 516 * 128 + swap 298 * + -8 shift clamp ; inline\r
-\r
-: compute-green ( y u v -- g )\r
- >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift clamp ;\r
- inline\r
-\r
-: compute-red ( y u v -- g )\r
- nip 409 * swap 298 * + 128 + -8 shift clamp ; inline\r
-\r
-: compute-rgb ( y u v -- b g r )\r
- [ compute-blue ] 3keep [ compute-green ] 3keep compute-red ;\r
- inline\r
-\r
-: store-rgb ( index rgb b g r -- index )\r
- >r\r
- >r pick 0 + >fixnum pick set-uchar-nth\r
- r> pick 1 + >fixnum pick set-uchar-nth\r
- r> pick 2 + >fixnum pick set-uchar-nth\r
- drop ; inline\r
-\r
-: yuv>rgb-pixel ( index rgb yuv uvy yy x -- index )\r
- compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline\r
-\r
-: yuv>rgb-row ( index rgb yuv y -- index )\r
- over stride\r
- pick yuv_buffer-y_width >fixnum\r
- [ yuv>rgb-pixel ] each-with4 ; inline\r
-\r
-: yuv>rgb ( rgb yuv -- )\r
- 0 -rot\r
- dup yuv_buffer-y_height >fixnum\r
- [ yuv>rgb-row ] each-with2\r
- drop ;\r
-\r
-HINTS: yuv>rgb byte-array byte-array ;\r
-\r
-: process-video ( player -- player )\r
- dup gadget>> [\r
- {\r
- [ [ td>> ] [ yuv>> ] bi theora_decode_YUVout drop ]\r
- [ [ rgb>> ] [ yuv>> ] bi yuv>rgb ]\r
- [ gadget>> relayout-1 yield ]\r
- [ ]\r
- } cleave\r
- ] when ;\r
-\r
-: num-audio-buffers-processed ( player -- player n )\r
- dup source>> AL_BUFFERS_PROCESSED 0 <uint>\r
- [ alGetSourcei check-error ] keep *uint ;\r
-\r
-: append-new-audio-buffer ( player -- player )\r
- dup buffers>> 1 gen-buffers append >>buffers\r
- [ [ buffers>> second ] keep al-channel-format ] keep\r
- [ audio-buffer>> dup length ] keep\r
- [ vi>> vorbis_info-rate alBufferData check-error ] keep\r
- [ source>> 1 ] keep\r
- [ buffers>> second <uint> alSourceQueueBuffers check-error ] keep ;\r
-\r
-: fill-processed-audio-buffer ( player n -- player )\r
- #! n is the number of audio buffers processed\r
- over >r >r dup source>> r> pick buffer-indexes>>\r
- [ alSourceUnqueueBuffers check-error ] keep\r
- *uint dup r> swap >r al-channel-format rot\r
- [ audio-buffer>> dup length ] keep\r
- [ vi>> vorbis_info-rate alBufferData check-error ] keep\r
- [ source>> 1 ] keep\r
- r> <uint> swap >r alSourceQueueBuffers check-error r> ;\r
-\r
-: append-audio ( player -- player bool )\r
- num-audio-buffers-processed {\r
- { [ over buffers>> length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }\r
- { [ over buffers>> length 2 = over zero? and ] [ yield drop f ] }\r
- [ fill-processed-audio-buffer t ]\r
- } cond ;\r
-\r
-: start-audio ( player -- player bool )\r
- [ [ buffers>> first ] keep al-channel-format ] keep\r
- [ audio-buffer>> dup length ] keep\r
- [ vi>> vorbis_info-rate alBufferData check-error ] keep\r
- [ source>> 1 ] keep\r
- [ buffers>> first <uint> alSourceQueueBuffers check-error ] keep\r
- [ source>> alSourcePlay check-error ] keep\r
- t >>playing? t ;\r
-\r
-: process-audio ( player -- player bool )\r
- dup playing?>> [ append-audio ] [ start-audio ] if ;\r
-\r
-: read-bytes-into ( dest size stream -- len )\r
- #! Read the given number of bytes from a stream\r
- #! and store them in the destination byte array.\r
- stream-read >byte-array dup length [ memcpy ] keep ;\r
-\r
-: check-not-negative ( int -- )\r
- 0 < [ "Word result was a negative number." throw ] when ;\r
-\r
-: buffer-size ( -- number )\r
- 4096 ; inline\r
-\r
-: sync-buffer ( player -- buffer size player )\r
- [ oy>> buffer-size ogg_sync_buffer buffer-size ] keep ;\r
-\r
-: stream-into-buffer ( buffer size player -- len player )\r
- [ stream>> read-bytes-into ] keep ;\r
-\r
-: confirm-buffer ( len player -- player eof? )\r
- [ oy>> swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ;\r
-\r
-: buffer-data ( player -- player eof? )\r
- #! Take some compressed bitstream data and sync it for\r
- #! page extraction.\r
- sync-buffer stream-into-buffer confirm-buffer ;\r
-\r
-: queue-page ( player -- player )\r
- #! Push a page into the stream for packetization\r
- [ [ vo>> ] [ og>> ] bi ogg_stream_pagein drop ]\r
- [ [ to>> ] [ og>> ] bi ogg_stream_pagein drop ]\r
- [ ] tri ;\r
-\r
-: retrieve-page ( player -- player bool )\r
- #! Sync the streams and get a page. Return true if a page was\r
- #! successfully retrieved.\r
- dup [ oy>> ] [ og>> ] bi ogg_sync_pageout 0 > ;\r
-\r
-: standard-initial-header? ( player -- player bool )\r
- dup og>> ogg_page_bos zero? not ;\r
-\r
-: ogg-stream-init ( player -- state player )\r
- #! Init the encode/decode logical stream state\r
- [ temp-state>> ] keep\r
- [ og>> ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ;\r
-\r
-: ogg-stream-pagein ( state player -- state player )\r
- #! Add the incoming page to the stream state\r
- [ og>> ogg_stream_pagein drop ] 2keep ;\r
-\r
-: ogg-stream-packetout ( state player -- state player )\r
- [ op>> ogg_stream_packetout drop ] 2keep ;\r
-\r
-: decode-packet ( player -- state player )\r
- ogg-stream-init ogg-stream-pagein ogg-stream-packetout ;\r
-\r
-: theora-header? ( player -- player bool )\r
- #! Is the current page a theora header?\r
- dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header 0 >= ;\r
-\r
-: is-theora-packet? ( player -- player bool )\r
- dup theora>> zero? [ theora-header? ] [ f ] if ;\r
-\r
-: copy-to-theora-state ( state player -- player )\r
- #! Copy the state to the theora state structure in the player\r
- [ to>> swap dup length memcpy ] keep ;\r
-\r
-: handle-initial-theora-header ( state player -- player )\r
- copy-to-theora-state 1 >>theora ;\r
-\r
-: vorbis-header? ( player -- player bool )\r
- #! Is the current page a vorbis header?\r
- dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin 0 >= ;\r
-\r
-: is-vorbis-packet? ( player -- player bool )\r
- dup vorbis>> zero? [ vorbis-header? ] [ f ] if ;\r
-\r
-: copy-to-vorbis-state ( state player -- player )\r
- #! Copy the state to the vorbis state structure in the player\r
- [ vo>> swap dup length memcpy ] keep ;\r
-\r
-: handle-initial-vorbis-header ( state player -- player )\r
- copy-to-vorbis-state 1 >>vorbis ;\r
-\r
-: handle-initial-unknown-header ( state player -- player )\r
- swap ogg_stream_clear drop ;\r
-\r
-: process-initial-header ( player -- player bool )\r
- #! Is this a standard initial header? If not, stop parsing\r
- standard-initial-header? [\r
- decode-packet {\r
- { [ is-vorbis-packet? ] [ handle-initial-vorbis-header ] }\r
- { [ is-theora-packet? ] [ handle-initial-theora-header ] }\r
- [ handle-initial-unknown-header ]\r
- } cond t\r
- ] [\r
- f\r
- ] if ;\r
-\r
-: parse-initial-headers ( player -- player )\r
- #! Parse Vorbis headers, ignoring any other type stored\r
- #! in the Ogg container.\r
- retrieve-page [\r
- process-initial-header [\r
- parse-initial-headers\r
- ] [\r
- #! Don't leak the page, get it into the appropriate stream\r
- queue-page\r
- ] if\r
- ] [\r
- buffer-data not [ parse-initial-headers ] when\r
- ] if ;\r
-\r
-: have-required-vorbis-headers? ( player -- player bool )\r
- #! Return true if we need to decode vorbis due to there being\r
- #! vorbis headers read from the stream but we don't have them all\r
- #! yet.\r
- dup vorbis>> 1 2 between? not ;\r
-\r
-: have-required-theora-headers? ( player -- player bool )\r
- #! Return true if we need to decode theora due to there being\r
- #! theora headers read from the stream but we don't have them all\r
- #! yet.\r
- dup theora>> 1 2 between? not ;\r
-\r
-: get-remaining-vorbis-header-packet ( player -- player bool )\r
- dup [ vo>> ] [ op>> ] bi ogg_stream_packetout {\r
- { [ dup 0 < ] [ "Error parsing vorbis stream; corrupt stream?" throw ] }\r
- { [ dup zero? ] [ drop f ] }\r
- { [ t ] [ drop t ] }\r
- } cond ;\r
-\r
-: get-remaining-theora-header-packet ( player -- player bool )\r
- dup [ to>> ] [ op>> ] bi ogg_stream_packetout {\r
- { [ dup 0 < ] [ "Error parsing theora stream; corrupt stream?" throw ] }\r
- { [ dup zero? ] [ drop f ] }\r
- { [ t ] [ drop t ] }\r
- } cond ;\r
-\r
-: decode-remaining-vorbis-header-packet ( player -- player )\r
- dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin zero? [\r
- "Error parsing vorbis stream; corrupt stream?" throw\r
- ] unless ;\r
-\r
-: decode-remaining-theora-header-packet ( player -- player )\r
- dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header zero? [\r
- "Error parsing theora stream; corrupt stream?" throw\r
- ] unless ;\r
-\r
-: increment-vorbis-header-count ( player -- player )\r
- [ 1+ ] change-vorbis ;\r
-\r
-: increment-theora-header-count ( player -- player )\r
- [ 1+ ] change-theora ;\r
-\r
-: parse-remaining-vorbis-headers ( player -- player )\r
- have-required-vorbis-headers? not [\r
- get-remaining-vorbis-header-packet [\r
- decode-remaining-vorbis-header-packet\r
- increment-vorbis-header-count\r
- parse-remaining-vorbis-headers\r
- ] when\r
- ] when ;\r
-\r
-: parse-remaining-theora-headers ( player -- player )\r
- have-required-theora-headers? not [\r
- get-remaining-theora-header-packet [\r
- decode-remaining-theora-header-packet\r
- increment-theora-header-count\r
- parse-remaining-theora-headers\r
- ] when\r
- ] when ;\r
-\r
-: get-more-header-data ( player -- player )\r
- buffer-data drop ;\r
-\r
-: parse-remaining-headers ( player -- player )\r
- have-required-vorbis-headers? not swap have-required-theora-headers? not swapd or [\r
- parse-remaining-vorbis-headers\r
- parse-remaining-theora-headers\r
- retrieve-page [ queue-page ] [ get-more-header-data ] if\r
- parse-remaining-headers\r
- ] when ;\r
-\r
-: tear-down-vorbis ( player -- player )\r
- dup vi>> vorbis_info_clear\r
- dup vc>> vorbis_comment_clear ;\r
-\r
-: tear-down-theora ( player -- player )\r
- dup ti>> theora_info_clear\r
- dup tc>> theora_comment_clear ;\r
-\r
-: init-vorbis-codec ( player -- player )\r
- dup [ vd>> ] [ vi>> ] bi vorbis_synthesis_init drop\r
- dup [ vd>> ] [ vb>> ] bi vorbis_block_init drop ;\r
-\r
-: init-theora-codec ( player -- player )\r
- dup [ td>> ] [ ti>> ] bi theora_decode_init drop\r
- dup ti>> theora_info-frame_width over ti>> theora_info-frame_height\r
- 4 * * <byte-array> >>rgb ;\r
-\r
-\r
-: display-vorbis-details ( player -- player )\r
- [\r
- "Ogg logical stream " %\r
- dup vo>> ogg_stream_state-serialno #\r
- " is Vorbis " %\r
- dup vi>> vorbis_info-channels #\r
- " channel " %\r
- dup vi>> vorbis_info-rate #\r
- " Hz audio." %\r
- ] "" make print ;\r
-\r
-: display-theora-details ( player -- player )\r
- [\r
- "Ogg logical stream " %\r
- dup to>> ogg_stream_state-serialno #\r
- " is Theora " %\r
- dup ti>> theora_info-width #\r
- "x" %\r
- dup ti>> theora_info-height #\r
- " " %\r
- dup ti>> theora_info-fps_numerator\r
- over ti>> theora_info-fps_denominator /f #\r
- " fps video" %\r
- ] "" make print ;\r
-\r
-: initialize-decoder ( player -- player )\r
- dup vorbis>> zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if\r
- dup theora>> zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ;\r
-\r
-: sync-pages ( player -- player )\r
- retrieve-page [\r
- queue-page sync-pages\r
- ] when ;\r
-\r
-: audio-buffer-not-ready? ( player -- player bool )\r
- dup vorbis>> zero? not over audio-full?>> not and ;\r
-\r
-: pending-decoded-audio? ( player -- player pcm len bool )\r
- f <void*> 2dup >r vd>> r> vorbis_synthesis_pcmout dup 0 > ;\r
-\r
-: buffer-space-available ( player -- available )\r
- audio-buffer-size swap audio-index>> - ;\r
-\r
-: samples-to-read ( player available len -- numread )\r
- >r swap num-channels / r> min ;\r
-\r
-: each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline\r
-\r
-: add-to-buffer ( player val -- )\r
- over audio-index>> pick audio-buffer>> set-short-nth\r
- [ 1+ ] change-audio-index drop ;\r
-\r
-: get-audio-value ( pcm sample channel -- value )\r
- rot *void* void*-nth float-nth ;\r
-\r
-: process-channels ( player pcm sample channel -- )\r
- get-audio-value 32767.0 * >fixnum 32767 min -32768 max add-to-buffer ;\r
-\r
-: (process-sample) ( player pcm sample -- )\r
- pick num-channels [ process-channels ] each-with3 ;\r
-\r
-: process-samples ( player pcm numread -- )\r
- [ (process-sample) ] each-with2 ;\r
-\r
-: decode-pending-audio ( player pcm result -- player )\r
-! [ "ret = " % dup # ] "" make write\r
- pick [ buffer-space-available swap ] keep -rot samples-to-read\r
- pick over >r >r process-samples r> r> swap\r
- ! numread player\r
- dup audio-index>> audio-buffer-size = [\r
- t >>audio-full?\r
- ] when\r
- dup vd>> vorbis_dsp_state-granulepos dup 0 >= [\r
- ! numtoread player granulepos\r
- #! This is wrong: fix\r
- pick - >>audio-granulepos\r
- ] [\r
- ! numtoread player granulepos\r
- pick + >>audio-granulepos\r
- ] if\r
- [ vd>> swap vorbis_synthesis_read drop ] keep ;\r
-\r
-: no-pending-audio ( player -- player bool )\r
- #! No pending audio. Is there a pending packet to decode.\r
- dup [ vo>> ] [ op>> ] bi ogg_stream_packetout 0 > [\r
- dup [ vb>> ] [ op>> ] bi vorbis_synthesis 0 = [\r
- dup [ vd>> ] [ vb>> ] bi vorbis_synthesis_blockin drop\r
- ] when\r
- t\r
- ] [\r
- #! Need more data. Break out to suck in another page.\r
- f\r
- ] if ;\r
-\r
-: decode-audio ( player -- player )\r
- audio-buffer-not-ready? [\r
- #! If there's pending decoded audio, grab it\r
- pending-decoded-audio? [\r
- decode-pending-audio decode-audio\r
- ] [\r
- 2drop no-pending-audio [ decode-audio ] when\r
- ] if\r
- ] when ;\r
-\r
-: video-buffer-not-ready? ( player -- player bool )\r
- dup theora>> zero? not over video-ready?>> not and ;\r
-\r
-: decode-video ( player -- player )\r
- video-buffer-not-ready? [\r
- dup [ to>> ] [ op>> ] bi ogg_stream_packetout 0 > [\r
- dup [ td>> ] [ op>> ] bi theora_decode_packetin drop\r
- dup td>> theora_state-granulepos >>video-granulepos\r
- dup [ td>> ] [ video-granulepos>> ] bi theora_granule_time\r
- >>video-time\r
- t >>video-ready?\r
- decode-video\r
- ] when\r
- ] when ;\r
-\r
-: decode ( player -- player )\r
- get-more-header-data sync-pages\r
- decode-audio\r
- decode-video\r
- dup audio-full?>> [\r
- process-audio [\r
- f >>audio-full?\r
- 0 >>audio-index\r
- ] when\r
- ] when\r
- dup video-ready?>> [\r
- dup video-time>> over get-time - dup 0.0 < [\r
- -0.1 > [ process-video ] when\r
- f >>video-ready?\r
- ] [\r
- drop\r
- ] if\r
- ] when\r
- decode ;\r
-\r
-: free-malloced-objects ( player -- player )\r
- {\r
- [ op>> free ]\r
- [ oy>> free ]\r
- [ og>> free ]\r
- [ vo>> free ]\r
- [ vi>> free ]\r
- [ vd>> free ]\r
- [ vb>> free ]\r
- [ vc>> free ]\r
- [ to>> free ]\r
- [ ti>> free ]\r
- [ tc>> free ]\r
- [ td>> free ]\r
- [ ]\r
- } cleave ;\r
-\r
-\r
-: unqueue-openal-buffers ( player -- player )\r
- [\r
-\r
- num-audio-buffers-processed over source>> rot buffer-indexes>> swapd\r
- alSourceUnqueueBuffers check-error\r
- ] keep ;\r
-\r
-: delete-openal-buffers ( player -- player )\r
- [\r
- buffers>> [\r
- 1 swap <uint> alDeleteBuffers check-error\r
- ] each\r
- ] keep ;\r
-\r
-: delete-openal-source ( player -- player )\r
- [ source>> 1 swap <uint> alDeleteSources check-error ] keep ;\r
-\r
-: cleanup ( player -- player )\r
- free-malloced-objects\r
- unqueue-openal-buffers\r
- delete-openal-buffers\r
- delete-openal-source ;\r
-\r
-: wait-for-sound ( player -- player )\r
- #! Waits for the openal to finish playing remaining sounds\r
- dup source>> AL_SOURCE_STATE 0 <int> [ alGetSourcei check-error ] keep\r
- *int AL_PLAYING = [\r
- 100 sleep\r
- wait-for-sound\r
- ] when ;\r
-\r
-TUPLE: theora-gadget < gadget player ;\r
-\r
-: <theora-gadget> ( player -- gadget )\r
- theora-gadget new-gadget\r
- swap >>player ;\r
-\r
-M: theora-gadget pref-dim*\r
- player>>\r
- ti>> dup theora_info-width swap theora_info-height 2array ;\r
-\r
-M: theora-gadget draw-gadget* ( gadget -- )\r
- 0 0 glRasterPos2i\r
- 1.0 -1.0 glPixelZoom\r
- GL_UNPACK_ALIGNMENT 1 glPixelStorei\r
- [ pref-dim* first2 GL_RGB GL_UNSIGNED_BYTE ] keep\r
- player>> rgb>> glDrawPixels ;\r
-\r
-: initialize-gui ( gadget -- )\r
- "Theora Player" open-window ;\r
-\r
-: play-ogg ( player -- )\r
- parse-initial-headers\r
- parse-remaining-headers\r
- initialize-decoder\r
- dup gadget>> [ initialize-gui ] when*\r
- [ decode ] try\r
- wait-for-sound\r
- cleanup\r
- drop ;\r
-\r
-: play-vorbis-stream ( stream -- )\r
- <player> play-ogg ;\r
-\r
-: play-vorbis-file ( filename -- )\r
- binary <file-reader> play-vorbis-stream ;\r
-\r
-: play-theora-stream ( stream -- )\r
- <player>\r
- dup <theora-gadget> >>gadget\r
- play-ogg ;\r
-\r
-: play-theora-file ( filename -- )\r
- binary <file-reader> play-theora-stream ;\r
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! TODO:
+! based on number of channels in file.
+! - End of decoding is indicated by an exception when reading the stream.
+! How to work around this? C player example uses feof but streams don't
+! have that in Factor.
+! - Work out openal buffer method that plays nicely with streaming over
+! slow connections.
+! - Have start/stop/seek methods on the player object.
+!
+USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays
+ sequences libc shuffle alien.c-types system openal math
+ namespaces threads shuffle opengl arrays ui.gadgets.worlds
+ combinators math.parser ui.gadgets ui.render opengl.gl ui
+ continuations io.files hints combinators.lib sequences.lib
+ io.encodings.binary debugger math.order accessors ;
+
+IN: ogg.player
+
+: audio-buffer-size ( -- number ) 128 1024 * ; inline
+
+TUPLE: player stream temp-state
+ op oy og
+ vo vi vd vb vc vorbis
+ to ti tc td yuv rgb theora video-ready? video-time video-granulepos
+ source buffers buffer-indexes start-time
+ playing? audio-full? audio-index audio-buffer audio-granulepos
+ gadget ;
+
+: init-vorbis ( player -- )
+ dup oy>> ogg_sync_init drop
+ dup vi>> vorbis_info_init
+ vc>> vorbis_comment_init ;
+
+: init-theora ( player -- )
+ dup ti>> theora_info_init
+ tc>> theora_comment_init ;
+
+: init-sound ( player -- )
+ init-openal check-error
+ 1 gen-buffers check-error >>buffers
+ 2 "uint" <c-array> >>buffer-indexes
+ 1 gen-sources check-error first >>source drop ;
+
+: <player> ( stream -- player )
+ player new
+ swap >>stream
+ 0 >>vorbis
+ 0 >>theora
+ 0 >>video-time
+ 0 >>video-granulepos
+ f >>video-ready?
+ f >>audio-full?
+ 0 >>audio-index
+ 0 >>start-time
+ audio-buffer-size "short" <c-array> >>audio-buffer
+ 0 >>audio-granulepos
+ f >>playing?
+ "ogg_packet" malloc-object >>op
+ "ogg_sync_state" malloc-object >>oy
+ "ogg_page" malloc-object >>og
+ "ogg_stream_state" malloc-object >>vo
+ "vorbis_info" malloc-object >>vi
+ "vorbis_dsp_state" malloc-object >>vd
+ "vorbis_block" malloc-object >>vb
+ "vorbis_comment" malloc-object >>vc
+ "ogg_stream_state" malloc-object >>to
+ "theora_info" malloc-object >>ti
+ "theora_comment" malloc-object >>tc
+ "theora_state" malloc-object >>td
+ "yuv_buffer" <c-object> >>yuv
+ "ogg_stream_state" <c-object> >>temp-state
+ dup init-sound
+ dup init-vorbis
+ dup init-theora ;
+
+: num-channels ( player -- channels )
+ vi>> vorbis_info-channels ;
+
+: al-channel-format ( player -- format )
+ num-channels 1 = AL_FORMAT_MONO16 AL_FORMAT_STEREO16 ? ;
+
+: get-time ( player -- time )
+ dup start-time>> zero? [
+ millis >>start-time
+ ] when
+ start-time>> millis swap - 1000.0 /f ;
+
+: clamp ( n -- n )
+ 255 min 0 max ; inline
+
+: stride ( line yuv -- uvy yy )
+ [ yuv_buffer-uv_stride >fixnum swap 2/ * ] 2keep
+ yuv_buffer-y_stride >fixnum * >fixnum ; inline
+
+: each-with4 ( obj obj obj obj seq quot -- )
+ 4 each-withn ; inline
+
+: compute-y ( yuv uvy yy x -- y )
+ + >fixnum nip swap yuv_buffer-y uchar-nth 16 - ; inline
+
+: compute-v ( yuv uvy yy x -- v )
+ nip 2/ + >fixnum swap yuv_buffer-u uchar-nth 128 - ; inline
+
+: compute-u ( yuv uvy yy x -- v )
+ nip 2/ + >fixnum swap yuv_buffer-v uchar-nth 128 - ; inline
+
+: compute-yuv ( yuv uvy yy x -- y u v )
+ [ compute-y ] 4keep [ compute-u ] 4keep compute-v ; inline
+
+: compute-blue ( y u v -- b )
+ drop 516 * 128 + swap 298 * + -8 shift clamp ; inline
+
+: compute-green ( y u v -- g )
+ >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift clamp ;
+ inline
+
+: compute-red ( y u v -- g )
+ nip 409 * swap 298 * + 128 + -8 shift clamp ; inline
+
+: compute-rgb ( y u v -- b g r )
+ [ compute-blue ] 3keep [ compute-green ] 3keep compute-red ;
+ inline
+
+: store-rgb ( index rgb b g r -- index )
+ >r
+ >r pick 0 + >fixnum pick set-uchar-nth
+ r> pick 1 + >fixnum pick set-uchar-nth
+ r> pick 2 + >fixnum pick set-uchar-nth
+ drop ; inline
+
+: yuv>rgb-pixel ( index rgb yuv uvy yy x -- index )
+ compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline
+
+: yuv>rgb-row ( index rgb yuv y -- index )
+ over stride
+ pick yuv_buffer-y_width >fixnum
+ [ yuv>rgb-pixel ] each-with4 ; inline
+
+: yuv>rgb ( rgb yuv -- )
+ 0 -rot
+ dup yuv_buffer-y_height >fixnum
+ [ yuv>rgb-row ] each-with2
+ drop ;
+
+HINTS: yuv>rgb byte-array byte-array ;
+
+: process-video ( player -- player )
+ dup gadget>> [
+ {
+ [ [ td>> ] [ yuv>> ] bi theora_decode_YUVout drop ]
+ [ [ rgb>> ] [ yuv>> ] bi yuv>rgb ]
+ [ gadget>> relayout-1 yield ]
+ [ ]
+ } cleave
+ ] when ;
+
+: num-audio-buffers-processed ( player -- player n )
+ dup source>> AL_BUFFERS_PROCESSED 0 <uint>
+ [ alGetSourcei check-error ] keep *uint ;
+
+: append-new-audio-buffer ( player -- player )
+ dup buffers>> 1 gen-buffers append >>buffers
+ [ [ buffers>> second ] keep al-channel-format ] keep
+ [ audio-buffer>> dup length ] keep
+ [ vi>> vorbis_info-rate alBufferData check-error ] keep
+ [ source>> 1 ] keep
+ [ buffers>> second <uint> alSourceQueueBuffers check-error ] keep ;
+
+: fill-processed-audio-buffer ( player n -- player )
+ #! n is the number of audio buffers processed
+ over >r >r dup source>> r> pick buffer-indexes>>
+ [ alSourceUnqueueBuffers check-error ] keep
+ *uint dup r> swap >r al-channel-format rot
+ [ audio-buffer>> dup length ] keep
+ [ vi>> vorbis_info-rate alBufferData check-error ] keep
+ [ source>> 1 ] keep
+ r> <uint> swap >r alSourceQueueBuffers check-error r> ;
+
+: append-audio ( player -- player bool )
+ num-audio-buffers-processed {
+ { [ over buffers>> length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }
+ { [ over buffers>> length 2 = over zero? and ] [ yield drop f ] }
+ [ fill-processed-audio-buffer t ]
+ } cond ;
+
+: start-audio ( player -- player bool )
+ [ [ buffers>> first ] keep al-channel-format ] keep
+ [ audio-buffer>> dup length ] keep
+ [ vi>> vorbis_info-rate alBufferData check-error ] keep
+ [ source>> 1 ] keep
+ [ buffers>> first <uint> alSourceQueueBuffers check-error ] keep
+ [ source>> alSourcePlay check-error ] keep
+ t >>playing? t ;
+
+: process-audio ( player -- player bool )
+ dup playing?>> [ append-audio ] [ start-audio ] if ;
+
+: read-bytes-into ( dest size stream -- len )
+ #! Read the given number of bytes from a stream
+ #! and store them in the destination byte array.
+ stream-read >byte-array dup length [ memcpy ] keep ;
+
+: check-not-negative ( int -- )
+ 0 < [ "Word result was a negative number." throw ] when ;
+
+: buffer-size ( -- number )
+ 4096 ; inline
+
+: sync-buffer ( player -- buffer size player )
+ [ oy>> buffer-size ogg_sync_buffer buffer-size ] keep ;
+
+: stream-into-buffer ( buffer size player -- len player )
+ [ stream>> read-bytes-into ] keep ;
+
+: confirm-buffer ( len player -- player eof? )
+ [ oy>> swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ;
+
+: buffer-data ( player -- player eof? )
+ #! Take some compressed bitstream data and sync it for
+ #! page extraction.
+ sync-buffer stream-into-buffer confirm-buffer ;
+
+: queue-page ( player -- player )
+ #! Push a page into the stream for packetization
+ [ [ vo>> ] [ og>> ] bi ogg_stream_pagein drop ]
+ [ [ to>> ] [ og>> ] bi ogg_stream_pagein drop ]
+ [ ] tri ;
+
+: retrieve-page ( player -- player bool )
+ #! Sync the streams and get a page. Return true if a page was
+ #! successfully retrieved.
+ dup [ oy>> ] [ og>> ] bi ogg_sync_pageout 0 > ;
+
+: standard-initial-header? ( player -- player bool )
+ dup og>> ogg_page_bos zero? not ;
+
+: ogg-stream-init ( player -- state player )
+ #! Init the encode/decode logical stream state
+ [ temp-state>> ] keep
+ [ og>> ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ;
+
+: ogg-stream-pagein ( state player -- state player )
+ #! Add the incoming page to the stream state
+ [ og>> ogg_stream_pagein drop ] 2keep ;
+
+: ogg-stream-packetout ( state player -- state player )
+ [ op>> ogg_stream_packetout drop ] 2keep ;
+
+: decode-packet ( player -- state player )
+ ogg-stream-init ogg-stream-pagein ogg-stream-packetout ;
+
+: theora-header? ( player -- player bool )
+ #! Is the current page a theora header?
+ dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header 0 >= ;
+
+: is-theora-packet? ( player -- player bool )
+ dup theora>> zero? [ theora-header? ] [ f ] if ;
+
+: copy-to-theora-state ( state player -- player )
+ #! Copy the state to the theora state structure in the player
+ [ to>> swap dup length memcpy ] keep ;
+
+: handle-initial-theora-header ( state player -- player )
+ copy-to-theora-state 1 >>theora ;
+
+: vorbis-header? ( player -- player bool )
+ #! Is the current page a vorbis header?
+ dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin 0 >= ;
+
+: is-vorbis-packet? ( player -- player bool )
+ dup vorbis>> zero? [ vorbis-header? ] [ f ] if ;
+
+: copy-to-vorbis-state ( state player -- player )
+ #! Copy the state to the vorbis state structure in the player
+ [ vo>> swap dup length memcpy ] keep ;
+
+: handle-initial-vorbis-header ( state player -- player )
+ copy-to-vorbis-state 1 >>vorbis ;
+
+: handle-initial-unknown-header ( state player -- player )
+ swap ogg_stream_clear drop ;
+
+: process-initial-header ( player -- player bool )
+ #! Is this a standard initial header? If not, stop parsing
+ standard-initial-header? [
+ decode-packet {
+ { [ is-vorbis-packet? ] [ handle-initial-vorbis-header ] }
+ { [ is-theora-packet? ] [ handle-initial-theora-header ] }
+ [ handle-initial-unknown-header ]
+ } cond t
+ ] [
+ f
+ ] if ;
+
+: parse-initial-headers ( player -- player )
+ #! Parse Vorbis headers, ignoring any other type stored
+ #! in the Ogg container.
+ retrieve-page [
+ process-initial-header [
+ parse-initial-headers
+ ] [
+ #! Don't leak the page, get it into the appropriate stream
+ queue-page
+ ] if
+ ] [
+ buffer-data not [ parse-initial-headers ] when
+ ] if ;
+
+: have-required-vorbis-headers? ( player -- player bool )
+ #! Return true if we need to decode vorbis due to there being
+ #! vorbis headers read from the stream but we don't have them all
+ #! yet.
+ dup vorbis>> 1 2 between? not ;
+
+: have-required-theora-headers? ( player -- player bool )
+ #! Return true if we need to decode theora due to there being
+ #! theora headers read from the stream but we don't have them all
+ #! yet.
+ dup theora>> 1 2 between? not ;
+
+: get-remaining-vorbis-header-packet ( player -- player bool )
+ dup [ vo>> ] [ op>> ] bi ogg_stream_packetout {
+ { [ dup 0 < ] [ "Error parsing vorbis stream; corrupt stream?" throw ] }
+ { [ dup zero? ] [ drop f ] }
+ { [ t ] [ drop t ] }
+ } cond ;
+
+: get-remaining-theora-header-packet ( player -- player bool )
+ dup [ to>> ] [ op>> ] bi ogg_stream_packetout {
+ { [ dup 0 < ] [ "Error parsing theora stream; corrupt stream?" throw ] }
+ { [ dup zero? ] [ drop f ] }
+ { [ t ] [ drop t ] }
+ } cond ;
+
+: decode-remaining-vorbis-header-packet ( player -- player )
+ dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin zero? [
+ "Error parsing vorbis stream; corrupt stream?" throw
+ ] unless ;
+
+: decode-remaining-theora-header-packet ( player -- player )
+ dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header zero? [
+ "Error parsing theora stream; corrupt stream?" throw
+ ] unless ;
+
+: increment-vorbis-header-count ( player -- player )
+ [ 1+ ] change-vorbis ;
+
+: increment-theora-header-count ( player -- player )
+ [ 1+ ] change-theora ;
+
+: parse-remaining-vorbis-headers ( player -- player )
+ have-required-vorbis-headers? not [
+ get-remaining-vorbis-header-packet [
+ decode-remaining-vorbis-header-packet
+ increment-vorbis-header-count
+ parse-remaining-vorbis-headers
+ ] when
+ ] when ;
+
+: parse-remaining-theora-headers ( player -- player )
+ have-required-theora-headers? not [
+ get-remaining-theora-header-packet [
+ decode-remaining-theora-header-packet
+ increment-theora-header-count
+ parse-remaining-theora-headers
+ ] when
+ ] when ;
+
+: get-more-header-data ( player -- player )
+ buffer-data drop ;
+
+: parse-remaining-headers ( player -- player )
+ have-required-vorbis-headers? not swap have-required-theora-headers? not swapd or [
+ parse-remaining-vorbis-headers
+ parse-remaining-theora-headers
+ retrieve-page [ queue-page ] [ get-more-header-data ] if
+ parse-remaining-headers
+ ] when ;
+
+: tear-down-vorbis ( player -- player )
+ dup vi>> vorbis_info_clear
+ dup vc>> vorbis_comment_clear ;
+
+: tear-down-theora ( player -- player )
+ dup ti>> theora_info_clear
+ dup tc>> theora_comment_clear ;
+
+: init-vorbis-codec ( player -- player )
+ dup [ vd>> ] [ vi>> ] bi vorbis_synthesis_init drop
+ dup [ vd>> ] [ vb>> ] bi vorbis_block_init drop ;
+
+: init-theora-codec ( player -- player )
+ dup [ td>> ] [ ti>> ] bi theora_decode_init drop
+ dup ti>> theora_info-frame_width over ti>> theora_info-frame_height
+ 4 * * <byte-array> >>rgb ;
+
+
+: display-vorbis-details ( player -- player )
+ [
+ "Ogg logical stream " %
+ dup vo>> ogg_stream_state-serialno #
+ " is Vorbis " %
+ dup vi>> vorbis_info-channels #
+ " channel " %
+ dup vi>> vorbis_info-rate #
+ " Hz audio." %
+ ] "" make print ;
+
+: display-theora-details ( player -- player )
+ [
+ "Ogg logical stream " %
+ dup to>> ogg_stream_state-serialno #
+ " is Theora " %
+ dup ti>> theora_info-width #
+ "x" %
+ dup ti>> theora_info-height #
+ " " %
+ dup ti>> theora_info-fps_numerator
+ over ti>> theora_info-fps_denominator /f #
+ " fps video" %
+ ] "" make print ;
+
+: initialize-decoder ( player -- player )
+ dup vorbis>> zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if
+ dup theora>> zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ;
+
+: sync-pages ( player -- player )
+ retrieve-page [
+ queue-page sync-pages
+ ] when ;
+
+: audio-buffer-not-ready? ( player -- player bool )
+ dup vorbis>> zero? not over audio-full?>> not and ;
+
+: pending-decoded-audio? ( player -- player pcm len bool )
+ f <void*> 2dup >r vd>> r> vorbis_synthesis_pcmout dup 0 > ;
+
+: buffer-space-available ( player -- available )
+ audio-buffer-size swap audio-index>> - ;
+
+: samples-to-read ( player available len -- numread )
+ >r swap num-channels / r> min ;
+
+: each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline
+
+: add-to-buffer ( player val -- )
+ over audio-index>> pick audio-buffer>> set-short-nth
+ [ 1+ ] change-audio-index drop ;
+
+: get-audio-value ( pcm sample channel -- value )
+ rot *void* void*-nth float-nth ;
+
+: process-channels ( player pcm sample channel -- )
+ get-audio-value 32767.0 * >fixnum 32767 min -32768 max add-to-buffer ;
+
+: (process-sample) ( player pcm sample -- )
+ pick num-channels [ process-channels ] each-with3 ;
+
+: process-samples ( player pcm numread -- )
+ [ (process-sample) ] each-with2 ;
+
+: decode-pending-audio ( player pcm result -- player )
+! [ "ret = " % dup # ] "" make write
+ pick [ buffer-space-available swap ] keep -rot samples-to-read
+ pick over >r >r process-samples r> r> swap
+ ! numread player
+ dup audio-index>> audio-buffer-size = [
+ t >>audio-full?
+ ] when
+ dup vd>> vorbis_dsp_state-granulepos dup 0 >= [
+ ! numtoread player granulepos
+ #! This is wrong: fix
+ pick - >>audio-granulepos
+ ] [
+ ! numtoread player granulepos
+ pick + >>audio-granulepos
+ ] if
+ [ vd>> swap vorbis_synthesis_read drop ] keep ;
+
+: no-pending-audio ( player -- player bool )
+ #! No pending audio. Is there a pending packet to decode.
+ dup [ vo>> ] [ op>> ] bi ogg_stream_packetout 0 > [
+ dup [ vb>> ] [ op>> ] bi vorbis_synthesis 0 = [
+ dup [ vd>> ] [ vb>> ] bi vorbis_synthesis_blockin drop
+ ] when
+ t
+ ] [
+ #! Need more data. Break out to suck in another page.
+ f
+ ] if ;
+
+: decode-audio ( player -- player )
+ audio-buffer-not-ready? [
+ #! If there's pending decoded audio, grab it
+ pending-decoded-audio? [
+ decode-pending-audio decode-audio
+ ] [
+ 2drop no-pending-audio [ decode-audio ] when
+ ] if
+ ] when ;
+
+: video-buffer-not-ready? ( player -- player bool )
+ dup theora>> zero? not over video-ready?>> not and ;
+
+: decode-video ( player -- player )
+ video-buffer-not-ready? [
+ dup [ to>> ] [ op>> ] bi ogg_stream_packetout 0 > [
+ dup [ td>> ] [ op>> ] bi theora_decode_packetin drop
+ dup td>> theora_state-granulepos >>video-granulepos
+ dup [ td>> ] [ video-granulepos>> ] bi theora_granule_time
+ >>video-time
+ t >>video-ready?
+ decode-video
+ ] when
+ ] when ;
+
+: decode ( player -- player )
+ get-more-header-data sync-pages
+ decode-audio
+ decode-video
+ dup audio-full?>> [
+ process-audio [
+ f >>audio-full?
+ 0 >>audio-index
+ ] when
+ ] when
+ dup video-ready?>> [
+ dup video-time>> over get-time - dup 0.0 < [
+ -0.1 > [ process-video ] when
+ f >>video-ready?
+ ] [
+ drop
+ ] if
+ ] when
+ decode ;
+
+: free-malloced-objects ( player -- player )
+ {
+ [ op>> free ]
+ [ oy>> free ]
+ [ og>> free ]
+ [ vo>> free ]
+ [ vi>> free ]
+ [ vd>> free ]
+ [ vb>> free ]
+ [ vc>> free ]
+ [ to>> free ]
+ [ ti>> free ]
+ [ tc>> free ]
+ [ td>> free ]
+ [ ]
+ } cleave ;
+
+
+: unqueue-openal-buffers ( player -- player )
+ [
+
+ num-audio-buffers-processed over source>> rot buffer-indexes>> swapd
+ alSourceUnqueueBuffers check-error
+ ] keep ;
+
+: delete-openal-buffers ( player -- player )
+ [
+ buffers>> [
+ 1 swap <uint> alDeleteBuffers check-error
+ ] each
+ ] keep ;
+
+: delete-openal-source ( player -- player )
+ [ source>> 1 swap <uint> alDeleteSources check-error ] keep ;
+
+: cleanup ( player -- player )
+ free-malloced-objects
+ unqueue-openal-buffers
+ delete-openal-buffers
+ delete-openal-source ;
+
+: wait-for-sound ( player -- player )
+ #! Waits for the openal to finish playing remaining sounds
+ dup source>> AL_SOURCE_STATE 0 <int> [ alGetSourcei check-error ] keep
+ *int AL_PLAYING = [
+ 100 sleep
+ wait-for-sound
+ ] when ;
+
+TUPLE: theora-gadget < gadget player ;
+
+: <theora-gadget> ( player -- gadget )
+ theora-gadget new-gadget
+ swap >>player ;
+
+M: theora-gadget pref-dim*
+ player>>
+ ti>> dup theora_info-width swap theora_info-height 2array ;
+
+M: theora-gadget draw-gadget* ( gadget -- )
+ 0 0 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ GL_UNPACK_ALIGNMENT 1 glPixelStorei
+ [ pref-dim* first2 GL_RGB GL_UNSIGNED_BYTE ] keep
+ player>> rgb>> glDrawPixels ;
+
+: initialize-gui ( gadget -- )
+ "Theora Player" open-window ;
+
+: play-ogg ( player -- )
+ parse-initial-headers
+ parse-remaining-headers
+ initialize-decoder
+ dup gadget>> [ initialize-gui ] when*
+ [ decode ] try
+ wait-for-sound
+ cleanup
+ drop ;
+
+: play-vorbis-stream ( stream -- )
+ <player> play-ogg ;
+
+: play-vorbis-file ( filename -- )
+ binary <file-reader> play-vorbis-stream ;
+
+: play-theora-stream ( stream -- )
+ <player>
+ dup <theora-gadget> >>gadget
+ play-ogg ;
+
+: play-theora-file ( filename -- )
+ binary <file-reader> play-theora-stream ;
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: accessors kernel fry math math.vectors sequences arrays vectors assocs\r
- hashtables models models.range models.product combinators\r
- ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs\r
- ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;\r
-\r
-IN: ui.gadgets.tabs\r
-\r
-TUPLE: tabbed < frame names toggler content ;\r
-\r
-DEFER: (del-page)\r
-\r
-:: add-toggle ( n name model toggler -- )\r
- <frame>\r
- n name toggler parent>> '[ drop _ _ _ (del-page) ] "X" swap <bevel-button>\r
- @right grid-add\r
- n model name <toggle-button> @center grid-add\r
- toggler swap add-gadget drop ;\r
-\r
-: redo-toggler ( tabbed -- )\r
- [ names>> ] [ model>> ] [ toggler>> ] tri\r
- [ clear-gadget ] keep\r
- [ [ length ] keep ] 2dip\r
- '[ _ _ add-toggle ] 2each ;\r
-\r
-: refresh-book ( tabbed -- )\r
- model>> [ ] change-model ;\r
-\r
-: (del-page) ( n name tabbed -- )\r
- { [ [ remove ] change-names redo-toggler ]\r
- [ dupd [ names>> length ] [ model>> ] bi\r
- [ [ = ] keep swap [ 1- ] when\r
- [ < ] keep swap [ 1- ] when ] change-model ]\r
- [ content>> nth-gadget unparent ]\r
- [ refresh-book ]\r
- } cleave ;\r
-\r
-: add-page ( page name tabbed -- )\r
- [ names>> push ] 2keep\r
- [ [ names>> length 1 - swap ]\r
- [ model>> ]\r
- [ toggler>> ] tri add-toggle ]\r
- [ content>> swap add-gadget drop ]\r
- [ refresh-book ] tri ;\r
-\r
-: del-page ( name tabbed -- )\r
- [ names>> index ] 2keep (del-page) ;\r
-\r
-: new-tabbed ( assoc class -- tabbed )\r
- new-frame\r
- 0 <model> >>model\r
- <pile> 1 >>fill >>toggler\r
- dup toggler>> @left grid-add\r
- swap\r
- [ keys >vector >>names ]\r
- [ values over model>> <book> >>content dup content>> @center grid-add ]\r
- bi\r
- dup redo-toggler ;\r
- \r
-: <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;\r
+! Copyright (C) 2008 William Schlieper
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors kernel fry math math.vectors sequences arrays vectors assocs
+ hashtables models models.range models.product combinators
+ ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs
+ ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;
+
+IN: ui.gadgets.tabs
+
+TUPLE: tabbed < frame names toggler content ;
+
+DEFER: (del-page)
+
+:: add-toggle ( n name model toggler -- )
+ <frame>
+ n name toggler parent>> '[ drop _ _ _ (del-page) ] "X" swap <bevel-button>
+ @right grid-add
+ n model name <toggle-button> @center grid-add
+ toggler swap add-gadget drop ;
+
+: redo-toggler ( tabbed -- )
+ [ names>> ] [ model>> ] [ toggler>> ] tri
+ [ clear-gadget ] keep
+ [ [ length ] keep ] 2dip
+ '[ _ _ add-toggle ] 2each ;
+
+: refresh-book ( tabbed -- )
+ model>> [ ] change-model ;
+
+: (del-page) ( n name tabbed -- )
+ { [ [ remove ] change-names redo-toggler ]
+ [ dupd [ names>> length ] [ model>> ] bi
+ [ [ = ] keep swap [ 1- ] when
+ [ < ] keep swap [ 1- ] when ] change-model ]
+ [ content>> nth-gadget unparent ]
+ [ refresh-book ]
+ } cleave ;
+
+: add-page ( page name tabbed -- )
+ [ names>> push ] 2keep
+ [ [ names>> length 1 - swap ]
+ [ model>> ]
+ [ toggler>> ] tri add-toggle ]
+ [ content>> swap add-gadget drop ]
+ [ refresh-book ] tri ;
+
+: del-page ( name tabbed -- )
+ [ names>> index ] 2keep (del-page) ;
+
+: new-tabbed ( assoc class -- tabbed )
+ new-frame
+ 0 <model> >>model
+ <pile> 1 >>fill >>toggler
+ dup toggler>> @left grid-add
+ swap
+ [ keys >vector >>names ]
+ [ values over model>> <book> >>content dup content>> @center grid-add ]
+ bi
+ dup redo-toggler ;
+
+: <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;
-#include "master.hpp"\r
-\r
-namespace factor\r
-{\r
-\r
-factor_vm::factor_vm() :\r
- nursery(0,0),\r
- c_to_factor_func(NULL),\r
- profiling_p(false),\r
- gc_off(false),\r
- current_gc(NULL),\r
- gc_events(NULL),\r
- fep_disabled(false),\r
- full_output(false),\r
- last_nano_count(0)\r
-{\r
- primitive_reset_dispatch_stats();\r
-}\r
-\r
-}\r
+#include "master.hpp"
+
+namespace factor
+{
+
+factor_vm::factor_vm() :
+ nursery(0,0),
+ c_to_factor_func(NULL),
+ profiling_p(false),
+ gc_off(false),
+ current_gc(NULL),
+ gc_events(NULL),
+ fep_disabled(false),
+ full_output(false),
+ last_nano_count(0)
+{
+ primitive_reset_dispatch_stats();
+}
+
+}