Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
1dbc37e0cd
|
|
@ -1,5 +1,5 @@
|
|||
USING: generic help.markup help.syntax math memory
|
||||
namespaces sequences kernel.private layouts sorting classes
|
||||
namespaces sequences kernel.private layouts classes
|
||||
kernel.private vectors combinators quotations strings words
|
||||
assocs arrays math.order ;
|
||||
IN: kernel
|
||||
|
|
@ -241,7 +241,7 @@ ARTICLE: "conditionals" "Conditionals and logic"
|
|||
"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
|
||||
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
|
||||
|
||||
ARTICLE: "equality" "Equality and comparison testing"
|
||||
ARTICLE: "equality" "Equality"
|
||||
"There are two distinct notions of ``sameness'' when it comes to objects. You can test if two references point to the same object (" { $emphasis "identity comparison" } "), or you can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "). Both notions of equality are equality relations in the mathematical sense."
|
||||
$nl
|
||||
"Identity comparison:"
|
||||
|
|
@ -250,16 +250,8 @@ $nl
|
|||
{ $subsection = }
|
||||
"Custom value comparison methods:"
|
||||
{ $subsection equal? }
|
||||
"Utility class:"
|
||||
{ $subsection identity-tuple }
|
||||
"Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":"
|
||||
{ $subsection <=> }
|
||||
{ $subsection compare }
|
||||
{ $subsection invert-comparison }
|
||||
"Utilities for comparing objects:"
|
||||
{ $subsection after? }
|
||||
{ $subsection before? }
|
||||
{ $subsection after=? }
|
||||
{ $subsection before=? }
|
||||
"An object can be cloned; the clone has distinct identity but equal value:"
|
||||
{ $subsection clone } ;
|
||||
|
||||
|
|
@ -394,8 +386,6 @@ HELP: identity-tuple
|
|||
{ $unchecked-example "T{ foo } dup clone = ." "f" }
|
||||
} ;
|
||||
|
||||
{ <=> compare natural-sort sort-keys sort-values } related-words
|
||||
|
||||
HELP: clone
|
||||
{ $values { "obj" object } { "cloned" "a new object" } }
|
||||
{ $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
USING: help.markup help.syntax kernel math sequences quotations
|
||||
math.private ;
|
||||
USING: help.markup help.syntax kernel math quotations
|
||||
math.private words ;
|
||||
IN: math.order
|
||||
|
||||
HELP: <=>
|
||||
{ $values { "obj1" object } { "obj2" object } { "n" real } }
|
||||
{ $values { "obj1" object } { "obj2" object } { "symbol" symbol } }
|
||||
{ $contract
|
||||
"Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings."
|
||||
$nl
|
||||
|
|
@ -13,7 +13,6 @@ HELP: <=>
|
|||
{ { $link +eq+ } " - indicating that " { $snippet "obj1" } " is equal to " { $snippet "obj2" } }
|
||||
{ { $link +gt+ } " - indicating that " { $snippet "obj1" } " follows " { $snippet "obj2" } }
|
||||
}
|
||||
"The default implementation treats the two objects as sequences, and recursively compares their elements. So no extra work is required to compare sequences lexicographically."
|
||||
} ;
|
||||
|
||||
HELP: +lt+
|
||||
|
|
@ -77,3 +76,19 @@ HELP: [-]
|
|||
{ $values { "x" real } { "y" real } { "z" real } }
|
||||
{ $description "Subtracts " { $snippet "y" } " from " { $snippet "x" } ". If the result is less than zero, outputs zero." } ;
|
||||
|
||||
ARTICLE: "math.order" "Ordered objects"
|
||||
"Some classes have an intrinsic order amongst instances:"
|
||||
{ $subsection <=> }
|
||||
{ $subsection compare }
|
||||
{ $subsection invert-comparison }
|
||||
"The above words return one of the following symbols:"
|
||||
{ $subsection +lt+ }
|
||||
{ $subsection +eq+ }
|
||||
{ $subsection +gt+ }
|
||||
"Utilities for comparing objects:"
|
||||
{ $subsection after? }
|
||||
{ $subsection before? }
|
||||
{ $subsection after=? }
|
||||
{ $subsection before=? } ;
|
||||
|
||||
ABOUT: "math.order"
|
||||
|
|
|
|||
|
|
@ -7,11 +7,13 @@ SYMBOL: +lt+
|
|||
SYMBOL: +eq+
|
||||
SYMBOL: +gt+
|
||||
|
||||
GENERIC: <=> ( obj1 obj2 -- n )
|
||||
GENERIC: <=> ( obj1 obj2 -- symbol )
|
||||
|
||||
: (<=>) - dup 0 < [ drop +lt+ ] [ zero? +eq+ +gt+ ? ] if ;
|
||||
: (<=>) ( a b -- symbol )
|
||||
2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; inline
|
||||
|
||||
: invert-comparison ( symbol -- new-symbol )
|
||||
#! Can't use case, index or nth here
|
||||
dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ;
|
||||
|
||||
M: real <=> (<=>) ;
|
||||
|
|
|
|||
|
|
@ -62,3 +62,5 @@ HELP: binsearch*
|
|||
{ $description "Variant of " { $link binsearch } " which outputs the found element rather than its index in the sequence."
|
||||
$nl
|
||||
"Outputs " { $link f } " if the sequence is empty. If the sequence has at least one element, this word always outputs a sequence element." } ;
|
||||
|
||||
{ <=> compare natural-sort sort-keys sort-values } related-words
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ opengl.glu shuffle http.client vectors namespaces ui.gadgets
|
|||
ui.gadgets.canvas ui.render ui splitting combinators tools.time
|
||||
system combinators.lib float-arrays continuations
|
||||
opengl.demo-support multiline ui.gestures bunny.fixed-pipeline
|
||||
bunny.cel-shaded bunny.outlined bunny.model ;
|
||||
bunny.cel-shaded bunny.outlined bunny.model accessors ;
|
||||
IN: bunny
|
||||
|
||||
TUPLE: bunny-gadget model geom draw-seq draw-n ;
|
||||
|
|
@ -13,38 +13,33 @@ TUPLE: bunny-gadget model geom draw-seq draw-n ;
|
|||
0.0 0.0 0.375 <demo-gadget>
|
||||
maybe-download read-model {
|
||||
set-delegate
|
||||
set-bunny-gadget-model
|
||||
(>>model)
|
||||
} bunny-gadget construct ;
|
||||
|
||||
: bunny-gadget-draw ( gadget -- draw )
|
||||
{ bunny-gadget-draw-n bunny-gadget-draw-seq }
|
||||
{ draw-n>> draw-seq>> }
|
||||
get-slots nth ;
|
||||
|
||||
: bunny-gadget-next-draw ( gadget -- )
|
||||
dup { bunny-gadget-draw-seq bunny-gadget-draw-n }
|
||||
dup { draw-seq>> draw-n>> }
|
||||
get-slots
|
||||
1+ swap length mod
|
||||
swap [ set-bunny-gadget-draw-n ] keep relayout-1 ;
|
||||
>>draw-n relayout-1 ;
|
||||
|
||||
M: bunny-gadget graft* ( gadget -- )
|
||||
GL_DEPTH_TEST glEnable
|
||||
dup bunny-gadget-model <bunny-geom>
|
||||
over {
|
||||
[ <bunny-fixed-pipeline> ]
|
||||
[ <bunny-cel-shaded> ]
|
||||
[ <bunny-outlined> ]
|
||||
} map-call-with [ ] filter
|
||||
0
|
||||
roll {
|
||||
set-bunny-gadget-geom
|
||||
set-bunny-gadget-draw-seq
|
||||
set-bunny-gadget-draw-n
|
||||
} set-slots ;
|
||||
dup model>> <bunny-geom> >>geom
|
||||
dup
|
||||
[ <bunny-fixed-pipeline> ]
|
||||
[ <bunny-cel-shaded> ]
|
||||
[ <bunny-outlined> ] tri 3array
|
||||
[ ] filter >>draw-seq
|
||||
0 >>draw-n
|
||||
drop ;
|
||||
|
||||
M: bunny-gadget ungraft* ( gadget -- )
|
||||
{ bunny-gadget-geom bunny-gadget-draw-seq } get-slots
|
||||
[ [ dispose ] when* ] each
|
||||
[ dispose ] when* ;
|
||||
[ geom>> [ dispose ] when* ]
|
||||
[ draw-seq>> [ [ dispose ] when* ] each ] bi ;
|
||||
|
||||
M: bunny-gadget draw-gadget* ( gadget -- )
|
||||
0.15 0.15 0.15 1.0 glClearColor
|
||||
|
|
@ -52,7 +47,7 @@ M: bunny-gadget draw-gadget* ( gadget -- )
|
|||
dup demo-gadget-set-matrices
|
||||
GL_MODELVIEW glMatrixMode
|
||||
0.02 -0.105 0.0 glTranslatef
|
||||
{ bunny-gadget-geom bunny-gadget-draw } get-slots
|
||||
{ geom>> bunny-gadget-draw } get-slots
|
||||
draw-bunny ;
|
||||
|
||||
M: bunny-gadget pref-dim* ( gadget -- dim )
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: arrays bunny.model continuations kernel multiline opengl opengl.shaders
|
||||
opengl.capabilities opengl.gl sequences sequences.lib ;
|
||||
opengl.capabilities opengl.gl sequences sequences.lib accessors ;
|
||||
IN: bunny.cel-shaded
|
||||
|
||||
STRING: vertex-shader-source
|
||||
|
|
@ -68,11 +68,12 @@ TUPLE: bunny-cel-shaded program ;
|
|||
: <bunny-cel-shaded> ( gadget -- draw )
|
||||
drop
|
||||
cel-shading-supported? [
|
||||
bunny-cel-shaded new
|
||||
vertex-shader-source <vertex-shader> check-gl-shader
|
||||
cel-shaded-fragment-shader-lib-source <fragment-shader> check-gl-shader
|
||||
cel-shaded-fragment-shader-main-source <fragment-shader> check-gl-shader
|
||||
3array <gl-program> check-gl-program
|
||||
{ set-bunny-cel-shaded-program } bunny-cel-shaded construct
|
||||
>>program
|
||||
] [ f ] if ;
|
||||
|
||||
: (draw-cel-shaded-bunny) ( geom program -- )
|
||||
|
|
@ -85,8 +86,8 @@ TUPLE: bunny-cel-shaded program ;
|
|||
} [ bunny-geom ] with-gl-program ;
|
||||
|
||||
M: bunny-cel-shaded draw-bunny
|
||||
bunny-cel-shaded-program (draw-cel-shaded-bunny) ;
|
||||
program>> (draw-cel-shaded-bunny) ;
|
||||
|
||||
M: bunny-cel-shaded dispose
|
||||
bunny-cel-shaded-program delete-gl-program ;
|
||||
program>> delete-gl-program ;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ TUPLE: bunny-fixed-pipeline ;
|
|||
|
||||
: <bunny-fixed-pipeline> ( gadget -- draw )
|
||||
drop
|
||||
{ } bunny-fixed-pipeline construct ;
|
||||
bunny-fixed-pipeline new ;
|
||||
|
||||
M: bunny-fixed-pipeline draw-bunny
|
||||
drop
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: alien alien.c-types arrays sequences math math.vectors
|
|||
math.matrices math.parser io io.files kernel opengl opengl.gl
|
||||
opengl.glu io.encodings.ascii opengl.capabilities shuffle
|
||||
http.client vectors splitting tools.time system combinators
|
||||
float-arrays continuations namespaces sequences.lib ;
|
||||
float-arrays continuations namespaces sequences.lib accessors ;
|
||||
IN: bunny.model
|
||||
|
||||
: numbers ( str -- seq )
|
||||
|
|
@ -85,24 +85,24 @@ M: bunny-dlist bunny-geom
|
|||
bunny-dlist-list glCallList ;
|
||||
|
||||
M: bunny-buffers bunny-geom
|
||||
dup {
|
||||
bunny-buffers-array
|
||||
bunny-buffers-element-array
|
||||
} get-slots [
|
||||
dup { array>> element-array>> } get-slots [
|
||||
{ GL_VERTEX_ARRAY GL_NORMAL_ARRAY } [
|
||||
GL_DOUBLE 0 0 buffer-offset glNormalPointer
|
||||
dup bunny-buffers-nv "double" heap-size * buffer-offset
|
||||
3 GL_DOUBLE 0 roll glVertexPointer
|
||||
bunny-buffers-ni
|
||||
GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
|
||||
[
|
||||
nv>> "double" heap-size * buffer-offset
|
||||
3 GL_DOUBLE 0 roll glVertexPointer
|
||||
] [
|
||||
ni>>
|
||||
GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
|
||||
] bi
|
||||
] all-enabled-client-state
|
||||
] with-array-element-buffers ;
|
||||
|
||||
M: bunny-dlist dispose
|
||||
bunny-dlist-list delete-dlist ;
|
||||
list>> delete-dlist ;
|
||||
|
||||
M: bunny-buffers dispose
|
||||
{ bunny-buffers-array bunny-buffers-element-array } get-slots
|
||||
{ array>> element-array>> } get-slots
|
||||
delete-gl-buffer delete-gl-buffer ;
|
||||
|
||||
: <bunny-geom> ( model -- geom )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
USING: arrays bunny.model bunny.cel-shaded continuations kernel
|
||||
math multiline opengl opengl.shaders opengl.framebuffers
|
||||
opengl.gl opengl.capabilities sequences ui.gadgets combinators ;
|
||||
opengl.gl opengl.capabilities sequences ui.gadgets combinators
|
||||
accessors ;
|
||||
IN: bunny.outlined
|
||||
|
||||
STRING: outlined-pass1-fragment-shader-main-source
|
||||
|
|
@ -139,9 +140,9 @@ TUPLE: bunny-outlined
|
|||
: <bunny-outlined> ( gadget -- draw )
|
||||
outlining-supported? [
|
||||
pass1-program pass2-program {
|
||||
set-bunny-outlined-gadget
|
||||
set-bunny-outlined-pass1-program
|
||||
set-bunny-outlined-pass2-program
|
||||
(>>gadget)
|
||||
(>>pass1-program)
|
||||
(>>pass2-program)
|
||||
} bunny-outlined construct
|
||||
] [ drop f ] if ;
|
||||
|
||||
|
|
@ -169,35 +170,33 @@ TUPLE: bunny-outlined
|
|||
] with-framebuffer ;
|
||||
|
||||
: dispose-framebuffer ( draw -- )
|
||||
dup bunny-outlined-framebuffer-dim [
|
||||
dup framebuffer-dim>> [
|
||||
{
|
||||
[ bunny-outlined-framebuffer [ delete-framebuffer ] when* ]
|
||||
[ bunny-outlined-color-texture [ delete-texture ] when* ]
|
||||
[ bunny-outlined-normal-texture [ delete-texture ] when* ]
|
||||
[ bunny-outlined-depth-texture [ delete-texture ] when* ]
|
||||
[ f swap set-bunny-outlined-framebuffer-dim ]
|
||||
[ framebuffer>> [ delete-framebuffer ] when* ]
|
||||
[ color-texture>> [ delete-texture ] when* ]
|
||||
[ normal-texture>> [ delete-texture ] when* ]
|
||||
[ depth-texture>> [ delete-texture ] when* ]
|
||||
[ f >>framebuffer-dim drop ]
|
||||
} cleave
|
||||
] [ drop ] if ;
|
||||
|
||||
: remake-framebuffer-if-needed ( draw -- )
|
||||
dup bunny-outlined-gadget rect-dim
|
||||
over bunny-outlined-framebuffer-dim
|
||||
dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi
|
||||
over =
|
||||
[ 2drop ]
|
||||
[
|
||||
swap dup dispose-framebuffer >r
|
||||
dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
|
||||
swap dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
|
||||
swap dup GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture)
|
||||
swap >r
|
||||
[ (make-framebuffer) ] 3keep
|
||||
r> r> {
|
||||
set-bunny-outlined-framebuffer
|
||||
set-bunny-outlined-color-texture
|
||||
set-bunny-outlined-normal-texture
|
||||
set-bunny-outlined-depth-texture
|
||||
set-bunny-outlined-framebuffer-dim
|
||||
} set-slots
|
||||
[ 2drop ] [
|
||||
[ dup dispose-framebuffer dup ] dip {
|
||||
[
|
||||
GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
|
||||
[ >>color-texture drop ] keep
|
||||
] [
|
||||
GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
|
||||
[ >>normal-texture drop ] keep
|
||||
] [
|
||||
GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture)
|
||||
[ >>depth-texture drop ] keep
|
||||
]
|
||||
} 2cleave
|
||||
(make-framebuffer) >>framebuffer drop
|
||||
] if ;
|
||||
|
||||
: clear-framebuffer ( -- )
|
||||
|
|
@ -209,31 +208,34 @@ TUPLE: bunny-outlined
|
|||
GL_COLOR_BUFFER_BIT glClear ;
|
||||
|
||||
: (pass1) ( geom draw -- )
|
||||
dup bunny-outlined-framebuffer [
|
||||
dup framebuffer>> [
|
||||
clear-framebuffer
|
||||
{ GL_COLOR_ATTACHMENT0_EXT GL_COLOR_ATTACHMENT1_EXT } set-draw-buffers
|
||||
bunny-outlined-pass1-program (draw-cel-shaded-bunny)
|
||||
pass1-program>> (draw-cel-shaded-bunny)
|
||||
] with-framebuffer ;
|
||||
|
||||
: (pass2) ( draw -- )
|
||||
init-matrices
|
||||
dup bunny-outlined-color-texture GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
|
||||
dup bunny-outlined-normal-texture GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit
|
||||
dup bunny-outlined-depth-texture GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit
|
||||
bunny-outlined-pass2-program {
|
||||
{ "colormap" [ 0 glUniform1i ] }
|
||||
{ "normalmap" [ 1 glUniform1i ] }
|
||||
{ "depthmap" [ 2 glUniform1i ] }
|
||||
{ "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] }
|
||||
} [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] with-gl-program ;
|
||||
init-matrices {
|
||||
[ color-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
|
||||
[ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ]
|
||||
[ depth-texture>> GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ]
|
||||
[
|
||||
pass2-program>> {
|
||||
{ "colormap" [ 0 glUniform1i ] }
|
||||
{ "normalmap" [ 1 glUniform1i ] }
|
||||
{ "depthmap" [ 2 glUniform1i ] }
|
||||
{ "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] }
|
||||
} [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ]
|
||||
with-gl-program
|
||||
]
|
||||
} cleave ;
|
||||
|
||||
M: bunny-outlined draw-bunny
|
||||
dup remake-framebuffer-if-needed
|
||||
[ (pass1) ] keep (pass2) ;
|
||||
[ remake-framebuffer-if-needed ]
|
||||
[ (pass1) ]
|
||||
[ (pass2) ] tri ;
|
||||
|
||||
M: bunny-outlined dispose
|
||||
{
|
||||
[ bunny-outlined-pass1-program [ delete-gl-program ] when* ]
|
||||
[ bunny-outlined-pass2-program [ delete-gl-program ] when* ]
|
||||
[ dispose-framebuffer ]
|
||||
} cleave ;
|
||||
[ pass1-program>> [ delete-gl-program ] when* ]
|
||||
[ pass2-program>> [ delete-gl-program ] when* ]
|
||||
[ dispose-framebuffer ] tri ;
|
||||
|
|
|
|||
|
|
@ -104,6 +104,7 @@ $nl
|
|||
ARTICLE: "objects" "Objects"
|
||||
"An " { $emphasis "object" } " is any datum which may be identified. All values are objects in Factor. Each object carries type information, and types are checked at runtime; Factor is dynamically typed."
|
||||
{ $subsection "equality" }
|
||||
{ $subsection "math.order" }
|
||||
{ $subsection "classes" }
|
||||
{ $subsection "tuples" }
|
||||
{ $subsection "generic" }
|
||||
|
|
|
|||
|
|
@ -1,18 +1,11 @@
|
|||
USING: arrays combinators.lib kernel math math.functions
|
||||
math.order math.vectors namespaces opengl opengl.gl sequences ui
|
||||
ui.gadgets ui.gestures ui.render ;
|
||||
ui.gadgets ui.gestures ui.render accessors ;
|
||||
IN: opengl.demo-support
|
||||
|
||||
: NEAR-PLANE 1.0 64.0 / ; inline
|
||||
: FAR-PLANE 4.0 ; inline
|
||||
: FOV 2.0 sqrt 1+ ; inline
|
||||
: MOUSE-MOTION-SCALE 0.5 ; inline
|
||||
: MOUSE-DISTANCE-SCALE 1.0 64.0 / ; inline
|
||||
: KEY-ROTATE-STEP 1.0 ; inline
|
||||
: KEY-DISTANCE-STEP 1.0 64.0 / ; inline
|
||||
: DIMS { 640 480 } ; inline
|
||||
|
||||
: FOV-RATIO ( -- fov ) DIMS dup first2 min v/n ;
|
||||
|
||||
SYMBOL: last-drag-loc
|
||||
|
||||
|
|
@ -20,7 +13,20 @@ TUPLE: demo-gadget yaw pitch distance ;
|
|||
|
||||
: <demo-gadget> ( yaw pitch distance -- gadget )
|
||||
demo-gadget construct-gadget
|
||||
[ { set-demo-gadget-yaw set-demo-gadget-pitch set-demo-gadget-distance } set-slots ] keep ;
|
||||
[ { (>>yaw) (>>pitch) (>>distance) } set-slots ] keep ;
|
||||
|
||||
GENERIC: far-plane ( gadget -- z )
|
||||
GENERIC: near-plane ( gadget -- z )
|
||||
GENERIC: distance-step ( gadget -- dz )
|
||||
|
||||
M: demo-gadget far-plane ( gadget -- z )
|
||||
drop 4.0 ;
|
||||
M: demo-gadget near-plane ( gadget -- z )
|
||||
drop 1.0 64.0 / ;
|
||||
M: demo-gadget distance-step ( gadget -- dz )
|
||||
drop 1.0 64.0 / ;
|
||||
|
||||
: fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ;
|
||||
|
||||
: yaw-demo-gadget ( yaw gadget -- )
|
||||
[ [ demo-gadget-yaw + ] keep set-demo-gadget-yaw ] keep relayout-1 ;
|
||||
|
|
@ -32,26 +38,31 @@ TUPLE: demo-gadget yaw pitch distance ;
|
|||
[ [ demo-gadget-distance + ] keep set-demo-gadget-distance ] keep relayout-1 ;
|
||||
|
||||
M: demo-gadget pref-dim* ( gadget -- dim )
|
||||
drop DIMS ;
|
||||
drop { 640 480 } ;
|
||||
|
||||
: -+ ( x -- -x x )
|
||||
dup neg swap ;
|
||||
|
||||
: demo-gadget-frustum ( -- -x x -y y near far )
|
||||
FOV-RATIO NEAR-PLANE FOV / v*n
|
||||
first2 [ -+ ] bi@ NEAR-PLANE FAR-PLANE ;
|
||||
: demo-gadget-frustum ( gadget -- -x x -y y near far )
|
||||
[ near-plane ] [ far-plane ] [ fov-ratio ] tri [
|
||||
nip swap FOV / v*n
|
||||
first2 [ -+ ] bi@
|
||||
] 3keep drop ;
|
||||
|
||||
: demo-gadget-set-matrices ( gadget -- )
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
demo-gadget-frustum glFrustum
|
||||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity
|
||||
[ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ]
|
||||
[ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ]
|
||||
[ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ]
|
||||
tri ;
|
||||
[
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
demo-gadget-frustum glFrustum
|
||||
] [
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity
|
||||
[ >r 0.0 0.0 r> distance>> neg glTranslatef ]
|
||||
[ pitch>> 1.0 0.0 0.0 glRotatef ]
|
||||
[ yaw>> 0.0 1.0 0.0 glRotatef ]
|
||||
tri
|
||||
] bi ;
|
||||
|
||||
: reset-last-drag-rel ( -- )
|
||||
{ 0 0 } last-drag-loc set-global ;
|
||||
|
|
@ -66,11 +77,11 @@ demo-gadget H{
|
|||
{ T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-gadget ] }
|
||||
{ T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-gadget ] }
|
||||
{ T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-gadget ] }
|
||||
{ T{ key-down f f "=" } [ KEY-DISTANCE-STEP neg swap zoom-demo-gadget ] }
|
||||
{ T{ key-down f f "-" } [ KEY-DISTANCE-STEP swap zoom-demo-gadget ] }
|
||||
{ T{ key-down f f "=" } [ dup distance-step neg swap zoom-demo-gadget ] }
|
||||
{ T{ key-down f f "-" } [ dup distance-step swap zoom-demo-gadget ] }
|
||||
|
||||
{ T{ button-down f f 1 } [ drop reset-last-drag-rel ] }
|
||||
{ T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] }
|
||||
{ T{ mouse-scroll } [ scroll-direction get second MOUSE-DISTANCE-SCALE * swap zoom-demo-gadget ] }
|
||||
{ T{ mouse-scroll } [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] }
|
||||
} set-gestures
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,284 @@
|
|||
USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers
|
||||
opengl multiline ui.gadgets accessors sequences ui.render ui math
|
||||
arrays arrays.lib combinators ;
|
||||
IN: spheres
|
||||
|
||||
STRING: plane-vertex-shader
|
||||
varying vec3 object_position;
|
||||
void
|
||||
main()
|
||||
{
|
||||
object_position = gl_Vertex.xyz;
|
||||
gl_Position = ftransform();
|
||||
}
|
||||
;
|
||||
|
||||
STRING: plane-fragment-shader
|
||||
varying vec3 object_position;
|
||||
void
|
||||
main()
|
||||
{
|
||||
float distance_factor = (gl_FragCoord.z * 0.5 + 0.5);
|
||||
distance_factor = pow(distance_factor, 500.0)*0.5;
|
||||
|
||||
gl_FragColor = fract((floor(0.125*object_position.x)+floor(0.125*object_position.z)) * 0.5) == 0.0
|
||||
? vec4(1.0, 1.0 - distance_factor, 1.0 - distance_factor, 1.0)
|
||||
: vec4(1.0, distance_factor, distance_factor, 1.0);
|
||||
}
|
||||
;
|
||||
|
||||
STRING: sphere-vertex-shader
|
||||
attribute vec3 center;
|
||||
attribute float radius;
|
||||
attribute vec4 surface_color;
|
||||
varying float vradius;
|
||||
varying vec3 sphere_position;
|
||||
varying vec4 world_position, vcolor;
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
world_position = gl_ModelViewMatrix * vec4(center, 1);
|
||||
sphere_position = gl_Vertex.xyz;
|
||||
|
||||
gl_Position = gl_ProjectionMatrix * (world_position + vec4(sphere_position * radius, 0));
|
||||
|
||||
vcolor = surface_color;
|
||||
vradius = radius;
|
||||
}
|
||||
;
|
||||
|
||||
STRING: sphere-solid-color-fragment-shader
|
||||
uniform vec3 light_position;
|
||||
varying vec4 vcolor;
|
||||
|
||||
const vec4 ambient = vec4(0.25, 0.2, 0.25, 1.0);
|
||||
const vec4 diffuse = vec4(0.75, 0.8, 0.75, 1.0);
|
||||
|
||||
vec4
|
||||
sphere_color(vec3 point, vec3 normal)
|
||||
{
|
||||
vec3 transformed_light_position = (gl_ModelViewMatrix * vec4(light_position, 1)).xyz;
|
||||
vec3 direction = normalize(transformed_light_position - point);
|
||||
float d = max(0.0, dot(normal, direction));
|
||||
|
||||
return ambient * vcolor + diffuse * vec4(d * vcolor.rgb, vcolor.a);
|
||||
}
|
||||
;
|
||||
|
||||
STRING: sphere-texture-fragment-shader
|
||||
uniform samplerCube surface_texture;
|
||||
|
||||
vec4
|
||||
sphere_color(vec3 point, vec3 normal)
|
||||
{
|
||||
vec3 reflect = reflect(normalize(point), normal);
|
||||
return textureCube(surface_texture, reflect * gl_NormalMatrix);
|
||||
}
|
||||
;
|
||||
|
||||
STRING: sphere-main-fragment-shader
|
||||
varying float vradius;
|
||||
varying vec3 sphere_position;
|
||||
varying vec4 world_position;
|
||||
|
||||
vec4 sphere_color(vec3 point, vec3 normal);
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
float radius = length(sphere_position);
|
||||
if(radius > 1.0) discard;
|
||||
|
||||
vec3 surface = sphere_position + vec3(0.0, 0.0, sqrt(1.0 - radius*radius));
|
||||
vec4 world_surface = world_position + vec4(surface * vradius, 0);
|
||||
vec4 transformed_surface = gl_ProjectionMatrix * world_surface;
|
||||
|
||||
gl_FragDepth = (transformed_surface.z/transformed_surface.w + 1.0) * 0.5;
|
||||
gl_FragColor = sphere_color(world_surface.xyz, surface);
|
||||
}
|
||||
;
|
||||
|
||||
TUPLE: spheres-gadget
|
||||
plane-program solid-sphere-program texture-sphere-program
|
||||
reflection-framebuffer reflection-depthbuffer
|
||||
reflection-texture ;
|
||||
|
||||
: <spheres-gadget> ( -- gadget )
|
||||
20.0 10.0 20.0 <demo-gadget>
|
||||
{ set-delegate } spheres-gadget construct ;
|
||||
|
||||
M: spheres-gadget near-plane ( gadget -- z )
|
||||
drop 1.0 ;
|
||||
M: spheres-gadget far-plane ( gadget -- z )
|
||||
drop 512.0 ;
|
||||
M: spheres-gadget distance-step ( gadget -- dz )
|
||||
drop 0.5 ;
|
||||
|
||||
: (reflection-dim) ( -- w h )
|
||||
512 512 ;
|
||||
|
||||
: (make-reflection-texture) ( -- texture )
|
||||
gen-texture [
|
||||
GL_TEXTURE_CUBE_MAP swap glBindTexture
|
||||
GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
|
||||
GL_TEXTURE_CUBE_MAP GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
|
||||
GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
|
||||
GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri
|
||||
GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R GL_CLAMP glTexParameteri
|
||||
GL_TEXTURE_CUBE_MAP_POSITIVE_X
|
||||
GL_TEXTURE_CUBE_MAP_POSITIVE_Y
|
||||
GL_TEXTURE_CUBE_MAP_POSITIVE_Z
|
||||
GL_TEXTURE_CUBE_MAP_NEGATIVE_X
|
||||
GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
|
||||
GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 6 narray
|
||||
[ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ]
|
||||
each
|
||||
] keep ;
|
||||
|
||||
: (make-reflection-depthbuffer) ( -- depthbuffer )
|
||||
gen-renderbuffer [
|
||||
GL_RENDERBUFFER_EXT swap glBindRenderbufferEXT
|
||||
GL_RENDERBUFFER_EXT GL_DEPTH_COMPONENT32 (reflection-dim) glRenderbufferStorageEXT
|
||||
] keep ;
|
||||
|
||||
: (make-reflection-framebuffer) ( depthbuffer -- framebuffer )
|
||||
gen-framebuffer dup [
|
||||
swap >r
|
||||
GL_FRAMEBUFFER_EXT GL_DEPTH_ATTACHMENT_EXT GL_RENDERBUFFER_EXT r>
|
||||
glFramebufferRenderbufferEXT
|
||||
] with-framebuffer ;
|
||||
|
||||
: (plane-program) ( -- program )
|
||||
plane-vertex-shader plane-fragment-shader <simple-gl-program> ;
|
||||
: (solid-sphere-program) ( -- program )
|
||||
sphere-vertex-shader <vertex-shader> check-gl-shader
|
||||
sphere-solid-color-fragment-shader <fragment-shader> check-gl-shader
|
||||
sphere-main-fragment-shader <fragment-shader> check-gl-shader
|
||||
3array <gl-program> check-gl-program ;
|
||||
: (texture-sphere-program) ( -- program )
|
||||
sphere-vertex-shader <vertex-shader> check-gl-shader
|
||||
sphere-texture-fragment-shader <fragment-shader> check-gl-shader
|
||||
sphere-main-fragment-shader <fragment-shader> check-gl-shader
|
||||
3array <gl-program> check-gl-program ;
|
||||
|
||||
M: spheres-gadget graft* ( gadget -- )
|
||||
(plane-program) >>plane-program
|
||||
(solid-sphere-program) >>solid-sphere-program
|
||||
(texture-sphere-program) >>texture-sphere-program
|
||||
(make-reflection-texture) >>reflection-texture
|
||||
(make-reflection-depthbuffer) [ >>reflection-depthbuffer ] keep
|
||||
(make-reflection-framebuffer) >>reflection-framebuffer
|
||||
drop ;
|
||||
|
||||
M: spheres-gadget ungraft* ( gadget -- )
|
||||
{
|
||||
[ reflection-framebuffer>> [ delete-framebuffer ] when* ]
|
||||
[ reflection-depthbuffer>> [ delete-renderbuffer ] when* ]
|
||||
[ reflection-texture>> [ delete-texture ] when* ]
|
||||
[ solid-sphere-program>> [ delete-gl-program ] when* ]
|
||||
[ texture-sphere-program>> [ delete-gl-program ] when* ]
|
||||
[ plane-program>> [ delete-gl-program ] when* ]
|
||||
} cleave ;
|
||||
|
||||
M: spheres-gadget pref-dim* ( gadget -- dim )
|
||||
drop { 640 480 } ;
|
||||
|
||||
: (draw-sphere) ( program center radius surfacecolor -- )
|
||||
roll
|
||||
[ [ "center" glGetAttribLocation swap first3 glVertexAttrib3f ] curry ]
|
||||
[ [ "radius" glGetAttribLocation swap glVertexAttrib1f ] curry ]
|
||||
[ [ "surface_color" glGetAttribLocation swap first4 glVertexAttrib4f ] curry ]
|
||||
tri tri*
|
||||
{ -1.0 -1.0 } { 1.0 1.0 } rect-vertices ;
|
||||
|
||||
: sphere-scene ( gadget -- )
|
||||
GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
|
||||
[
|
||||
solid-sphere-program>> dup {
|
||||
{ "light_position" [ 0.0 0.0 100.0 glUniform3f ] }
|
||||
} [
|
||||
{
|
||||
[ { 7.0 0.0 0.0 } 1.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ]
|
||||
[ { -7.0 0.0 0.0 } 1.0 { 0.0 1.0 0.0 1.0 } (draw-sphere) ]
|
||||
[ { 0.0 0.0 7.0 } 1.0 { 0.0 0.0 1.0 1.0 } (draw-sphere) ]
|
||||
[ { 0.0 0.0 -7.0 } 1.0 { 1.0 1.0 0.0 1.0 } (draw-sphere) ]
|
||||
[ { 0.0 7.0 0.0 } 1.0 { 1.0 0.0 1.0 1.0 } (draw-sphere) ]
|
||||
[ { 0.0 -7.0 0.0 } 1.0 { 0.0 1.0 1.0 1.0 } (draw-sphere) ]
|
||||
} cleave
|
||||
] with-gl-program
|
||||
] [
|
||||
plane-program>> { } [
|
||||
GL_QUADS [
|
||||
-1000.0 -30.0 1000.0 glVertex3f
|
||||
-1000.0 -30.0 -1000.0 glVertex3f
|
||||
1000.0 -30.0 -1000.0 glVertex3f
|
||||
1000.0 -30.0 1000.0 glVertex3f
|
||||
] do-state
|
||||
] with-gl-program
|
||||
] bi ;
|
||||
|
||||
: reflection-frustum ( gadget -- -x x -y y near far )
|
||||
[ near-plane ] [ far-plane ] bi [
|
||||
drop dup [ -+ ] bi@
|
||||
] 2keep ;
|
||||
|
||||
: (reflection-face) ( gadget face -- )
|
||||
swap reflection-texture>> >r >r
|
||||
GL_FRAMEBUFFER_EXT
|
||||
GL_COLOR_ATTACHMENT0_EXT
|
||||
r> r> 0 glFramebufferTexture2DEXT
|
||||
check-framebuffer ;
|
||||
|
||||
: (draw-reflection-texture) ( gadget -- )
|
||||
dup reflection-framebuffer>> [ {
|
||||
[ drop 0 0 (reflection-dim) glViewport ]
|
||||
[
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
reflection-frustum glFrustum
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity
|
||||
180.0 0.0 0.0 1.0 glRotatef
|
||||
]
|
||||
[ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z (reflection-face) ]
|
||||
[ sphere-scene ]
|
||||
[ GL_TEXTURE_CUBE_MAP_POSITIVE_X (reflection-face)
|
||||
90.0 0.0 1.0 0.0 glRotatef ]
|
||||
[ sphere-scene ]
|
||||
[ GL_TEXTURE_CUBE_MAP_POSITIVE_Z (reflection-face)
|
||||
90.0 0.0 1.0 0.0 glRotatef glPushMatrix ]
|
||||
[ sphere-scene ]
|
||||
[ GL_TEXTURE_CUBE_MAP_NEGATIVE_X (reflection-face)
|
||||
90.0 0.0 1.0 0.0 glRotatef ]
|
||||
[ sphere-scene ]
|
||||
[ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y (reflection-face)
|
||||
glPopMatrix glPushMatrix -90.0 1.0 0.0 0.0 glRotatef ]
|
||||
[ sphere-scene ]
|
||||
[ GL_TEXTURE_CUBE_MAP_POSITIVE_Y (reflection-face)
|
||||
glPopMatrix 90.0 1.0 0.0 0.0 glRotatef ]
|
||||
[ sphere-scene ]
|
||||
[ dim>> 0 0 rot first2 glViewport ]
|
||||
} cleave ] with-framebuffer ;
|
||||
|
||||
M: spheres-gadget draw-gadget* ( gadget -- )
|
||||
GL_DEPTH_TEST glEnable
|
||||
GL_SCISSOR_TEST glDisable
|
||||
0.15 0.15 1.0 1.0 glClearColor {
|
||||
[ (draw-reflection-texture) ]
|
||||
[ demo-gadget-set-matrices ]
|
||||
[ sphere-scene ]
|
||||
[ reflection-texture>> GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit ]
|
||||
[
|
||||
texture-sphere-program>> dup {
|
||||
{ "surface_texture" [ 0 glUniform1i ] }
|
||||
} [
|
||||
{ 0.0 0.0 0.0 } 4.0 { 1.0 0.0 0.0 1.0 } (draw-sphere)
|
||||
] with-gl-program
|
||||
]
|
||||
} cleave ;
|
||||
|
||||
: spheres-window ( -- )
|
||||
[ <spheres-gadget> "Spheres" open-window ] with-ui ;
|
||||
|
||||
MAIN: spheres-window
|
||||
|
|
@ -0,0 +1 @@
|
|||
Draw pixel-perfect spheres using GLSL shaders
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
opengl
|
||||
glsl
|
||||
|
|
@ -4,7 +4,7 @@ IN: windows.com
|
|||
|
||||
HELP: com-query-interface
|
||||
{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } { "iid" "An interface GUID (IID)" } { "interface'" "Pointer to a COM interface implementing the interface indicated by " { $snippet "iid" } } }
|
||||
{ $description "A small wrapper around " { $link IUnknown::QueryInterface } ". Queries " { $snippet "interface" } " to see if it implements the interface indicated by " { $snippet "iid" } ". Returns a pointer to the " { $snippet "iid" } " interface if implemented, or raises an error if the object does not implement the interface.\n\nCOM memory management conventions state that the returned pointer must be immediately retained using " { $link com-add-ref } ". The pointer must then be released using " { $link com-release } " when it is no longer needed." } ;
|
||||
{ $description "A small wrapper around " { $link IUnknown::QueryInterface } ". Queries " { $snippet "interface" } " to see if it implements the interface indicated by " { $snippet "iid" } ". Returns a pointer to the " { $snippet "iid" } " interface if implemented, or raises an error if the object does not implement the interface.\n\nCOM memory management conventions state that the returned pointer must be released using " { $link com-release } " when it is no longer needed." } ;
|
||||
|
||||
HELP: com-add-ref
|
||||
{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }
|
||||
|
|
|
|||
|
|
@ -1,93 +1,91 @@
|
|||
USING: kernel windows.com windows.com.syntax windows.ole32
|
||||
alien alien.syntax tools.test libc alien.c-types arrays.lib
|
||||
namespaces arrays continuations ;
|
||||
IN: windows.com.tests
|
||||
|
||||
! Create some test COM interfaces
|
||||
|
||||
COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
|
||||
HRESULT returnOK ( )
|
||||
HRESULT returnError ( ) ;
|
||||
|
||||
COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
|
||||
int getX ( )
|
||||
void setX ( int newX ) ;
|
||||
|
||||
! Implement the IInherited interface in factor using alien-callbacks
|
||||
|
||||
C-STRUCT: test-implementation
|
||||
{ "void*" "vtbl" }
|
||||
{ "int" "x" } ;
|
||||
|
||||
: QueryInterface-callback
|
||||
"HRESULT" { "void*" "REFGUID" "void**" } "stdcall" [ nip 0 swap set-void*-nth S_OK ]
|
||||
alien-callback ;
|
||||
: AddRef-callback
|
||||
"ULONG" { "void*" } "stdcall" [ drop 2 ]
|
||||
alien-callback ;
|
||||
: Release-callback
|
||||
"ULONG" { "void*" } "stdcall" [ drop 1 ]
|
||||
alien-callback ;
|
||||
: returnOK-callback
|
||||
"HRESULT" { "void*" } "stdcall" [ drop S_OK ]
|
||||
alien-callback ;
|
||||
: returnError-callback
|
||||
"HRESULT" { "void*" } "stdcall" [ drop E_FAIL ]
|
||||
alien-callback ;
|
||||
: getX-callback
|
||||
"int" { "void*" } "stdcall" [ test-implementation-x ]
|
||||
alien-callback ;
|
||||
: setX-callback
|
||||
"void" { "void*" "int" } "stdcall" [ swap set-test-implementation-x ]
|
||||
alien-callback ;
|
||||
|
||||
SYMBOL: +test-implementation-vtbl+
|
||||
SYMBOL: +guinea-pig-implementation+
|
||||
|
||||
: (make-test-implementation) ( x imp -- imp )
|
||||
[ set-test-implementation-x ] keep
|
||||
+test-implementation-vtbl+ get over set-test-implementation-vtbl ;
|
||||
|
||||
: <test-implementation> ( x -- imp )
|
||||
"test-implementation" <c-object> (make-test-implementation) ;
|
||||
|
||||
: <malloced-test-implementation> ( x -- imp )
|
||||
"test-implementation" heap-size malloc (make-test-implementation) ;
|
||||
|
||||
QueryInterface-callback
|
||||
AddRef-callback
|
||||
Release-callback
|
||||
returnOK-callback
|
||||
returnError-callback
|
||||
getX-callback
|
||||
setX-callback
|
||||
7 narray >c-void*-array
|
||||
dup byte-length [
|
||||
[ byte-array>memory ] keep
|
||||
+test-implementation-vtbl+ set
|
||||
|
||||
! Test that the words defined by COM-INTERFACE: do their magic
|
||||
|
||||
"{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test
|
||||
"{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test
|
||||
"{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test
|
||||
S_OK 1array [ 0 <test-implementation> ISimple::returnOK ] unit-test
|
||||
E_FAIL <long> *long 1array [ 0 <test-implementation> ISimple::returnError ] unit-test
|
||||
1984 1array [ 0 <test-implementation> dup 1984 IInherited::setX IInherited::getX ] unit-test
|
||||
|
||||
! Test that the helper functions for QueryInterface, AddRef, Release work
|
||||
|
||||
0 <malloced-test-implementation> +guinea-pig-implementation+ set
|
||||
[
|
||||
+guinea-pig-implementation+ get 1array [
|
||||
+guinea-pig-implementation+ get com-add-ref
|
||||
] unit-test
|
||||
|
||||
{ } [ +guinea-pig-implementation+ get com-release ] unit-test
|
||||
|
||||
+guinea-pig-implementation+ get 1array [
|
||||
+guinea-pig-implementation+ get IUnknown-iid com-query-interface
|
||||
] unit-test
|
||||
|
||||
] [ +guinea-pig-implementation+ get free ] [ ] cleanup
|
||||
] with-malloc
|
||||
USING: kernel windows.com windows.com.syntax windows.ole32
|
||||
alien alien.syntax tools.test libc alien.c-types arrays.lib
|
||||
namespaces arrays continuations accessors math windows.com.wrapper
|
||||
windows.com.wrapper.private ;
|
||||
IN: windows.com.tests
|
||||
|
||||
COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
|
||||
HRESULT returnOK ( )
|
||||
HRESULT returnError ( ) ;
|
||||
|
||||
COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
|
||||
int getX ( )
|
||||
void setX ( int newX ) ;
|
||||
|
||||
COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c}
|
||||
int xPlus ( int y )
|
||||
int xMulAdd ( int mul, int add ) ;
|
||||
|
||||
"{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test
|
||||
"{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test
|
||||
"{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test
|
||||
"{b06ac3f4-30e4-406b-a7cd-c29cead4552c}" string>guid 1array [ IUnrelated-iid ] unit-test
|
||||
|
||||
SYMBOL: +test-wrapper+
|
||||
SYMBOL: +guinea-pig-implementation+
|
||||
SYMBOL: +orig-wrapped-objects+
|
||||
|
||||
+wrapped-objects+ get-global clone +orig-wrapped-objects+ set-global
|
||||
|
||||
TUPLE: test-implementation x ;
|
||||
C: <test-implementation> test-implementation
|
||||
|
||||
{
|
||||
{ "IInherited" {
|
||||
[ drop S_OK ] ! ISimple::returnOK
|
||||
[ drop E_FAIL ] ! ISimple::returnError
|
||||
[ x>> ] ! IInherited::getX
|
||||
[ >>x drop ] ! IInherited::setX
|
||||
} }
|
||||
{ "IUnrelated" {
|
||||
[ swap x>> + ] ! IUnrelated::xPlus
|
||||
[ spin x>> * + ] ! IUnrealted::xMulAdd
|
||||
} }
|
||||
} <com-wrapper>
|
||||
dup +test-wrapper+ set [
|
||||
|
||||
0 <test-implementation> swap com-wrap
|
||||
dup +guinea-pig-implementation+ set [ drop
|
||||
|
||||
S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test
|
||||
E_FAIL <long> *long 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
|
||||
20 1array [ +guinea-pig-implementation+ get dup 20 IInherited::setX IInherited::getX ] unit-test
|
||||
420 1array [
|
||||
+guinea-pig-implementation+ get
|
||||
IUnrelated-iid com-query-interface
|
||||
[ 20 20 IUnrelated::xMulAdd ] with-com-interface
|
||||
] unit-test
|
||||
40 1array [
|
||||
+guinea-pig-implementation+ get
|
||||
IUnrelated-iid com-query-interface
|
||||
[ 20 IUnrelated::xPlus ] with-com-interface
|
||||
] unit-test
|
||||
|
||||
+guinea-pig-implementation+ get 1array [
|
||||
+guinea-pig-implementation+ get com-add-ref
|
||||
] unit-test
|
||||
|
||||
{ } [ +guinea-pig-implementation+ get com-release ] unit-test
|
||||
|
||||
+guinea-pig-implementation+ get 1array [
|
||||
+guinea-pig-implementation+ get IUnknown-iid com-query-interface
|
||||
dup com-release
|
||||
] unit-test
|
||||
+guinea-pig-implementation+ get 1array [
|
||||
+guinea-pig-implementation+ get ISimple-iid com-query-interface
|
||||
dup com-release
|
||||
] unit-test
|
||||
"void*" heap-size +guinea-pig-implementation+ get <displaced-alien>
|
||||
+guinea-pig-implementation+ get
|
||||
2array [
|
||||
+guinea-pig-implementation+ get IUnrelated-iid com-query-interface
|
||||
dup ISimple-iid com-query-interface
|
||||
over com-release dup com-release
|
||||
] unit-test
|
||||
|
||||
] with-com-interface
|
||||
|
||||
] with-disposal
|
||||
|
||||
! Ensure that we freed +guinea-pig-implementation
|
||||
+orig-wrapped-objects+ get-global 1array [ +wrapped-objects+ get-global ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,12 +1,31 @@
|
|||
USING: alien alien.c-types windows.com.syntax windows.ole32
|
||||
windows.types continuations kernel ;
|
||||
windows.types continuations kernel alien.syntax ;
|
||||
IN: windows.com
|
||||
|
||||
LIBRARY: ole32
|
||||
|
||||
COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
|
||||
HRESULT QueryInterface ( REFGUID iid, void** ppvObject )
|
||||
ULONG AddRef ( )
|
||||
ULONG Release ( ) ;
|
||||
|
||||
COM-INTERFACE: IDataObject IUnknown {0000010E-0000-0000-C000-000000000046}
|
||||
HRESULT GetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )
|
||||
HRESULT GetDataHere ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )
|
||||
HRESULT QueryGetData ( FORMATETC* pFormatetc )
|
||||
HRESULT GetCanonicalFormatEtc ( FORMATETC* pFormatetcIn, FORMATETC* pFormatetcOut )
|
||||
HRESULT SetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium, BOOL fRelease )
|
||||
HRESULT EnumFormatEtc ( DWORD dwDirection, IEnumFORMATETC** ppenumFormatetc )
|
||||
HRESULT DAdvise ( FORMATETC* pFormatetc, DWORD advf, IAdviseSink* pAdvSink, DWORD* pdwConnection )
|
||||
HRESULT DUnadvise ( DWORD pdwConnection )
|
||||
HRESULT EnumDAdvise ( IEnumSTATDATA** ppenumAdvise ) ;
|
||||
|
||||
COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}
|
||||
HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
|
||||
HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
|
||||
HRESULT DragLeave ( )
|
||||
HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;
|
||||
|
||||
: com-query-interface ( interface iid -- interface' )
|
||||
f <void*>
|
||||
[ IUnknown::QueryInterface ole32-error ] keep
|
||||
|
|
@ -19,4 +38,4 @@ COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
|
|||
IUnknown::Release drop ; inline
|
||||
|
||||
: with-com-interface ( interface quot -- )
|
||||
[ keep ] [ com-release ] [ ] cleanup ; inline
|
||||
over [ slip ] [ com-release ] [ ] cleanup ; inline
|
||||
|
|
|
|||
|
|
@ -55,8 +55,12 @@ unless
|
|||
: (function-word) ( function interface -- word )
|
||||
name>> "::" rot name>> 3append create-in ;
|
||||
|
||||
: all-functions ( definition -- functions )
|
||||
dup parent>> [ all-functions ] [ { } ] if*
|
||||
: family-tree ( definition -- definitions )
|
||||
dup parent>> [ family-tree ] [ { } ] if*
|
||||
swap add ;
|
||||
|
||||
: family-tree-functions ( definition -- functions )
|
||||
dup parent>> [ family-tree-functions ] [ { } ] if*
|
||||
swap functions>> append ;
|
||||
|
||||
: (define-word-for-function) ( function interface n -- )
|
||||
|
|
@ -69,7 +73,7 @@ unless
|
|||
[ [ (iid-word) ] [ iid>> 1quotation ] bi define ]
|
||||
[ name>> "com-interface" swap typedef ]
|
||||
[
|
||||
dup all-functions
|
||||
dup family-tree-functions
|
||||
[ (define-word-for-function) ] with each-index
|
||||
]
|
||||
tri ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1 @@
|
|||
Wrap Factor objects with implementations of COM interfaces
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
windows
|
||||
com
|
||||
bindings
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
USING: help.markup help.syntax io kernel math quotations
|
||||
multiline alien windows.com windows.com.syntax continuations ;
|
||||
IN: windows.com.wrapper
|
||||
|
||||
HELP: <com-wrapper>
|
||||
{ $values { "implementations" "an assoc relating COM interface names to arrays of quotations implementing that interface" } { "wrapper" "a " { $link com-wrapper } " tuple" } }
|
||||
{ $description "Constructs a " { $link com-wrapper } " tuple. Each key in the " { $snippet "implementations" } " assoc must be the name of an interface defined with " { $link POSTPONE: COM-INTERFACE: } ". The corresponding value must be an array of quotations implementing the methods of that interface in order, including those of its parent interfaces. The " { $snippet "IUnknown" } " methods (" { $link IUnknown::QueryInterface } ", " { $link IUnknown::AddRef } ", and " { $link IUnknown::Release } ") will be defined automatically and must not be specified in the array. These quotations should have stack effects mirroring those of the interface methods being implemented; for example, a method " { $snippet "void foobar ( int foo, int bar )" } " should be implemented with a quotation of effect " { $snippet "( this foo bar -- )" } ". The " { $snippet "this" } " parameter (that is, the leftmost parameter of any COM method) will be automatically converted from an alien pointer to the underlying Factor object before the quotation is invoked.\n\nThe resulting wrapper can be applied to a Factor object using the " { $link com-wrap } " word. The COM interface pointer returned by " { $snippet "com-wrap" } " can then be passed to C functions requiring a COM object as a parameter. The vtables constructed by " { $snippet "<com-wrapper>" } " are stored on the non-GC heap in order to be accessible to C functions; when the wrapper objects and its vtables are no longer needed, the object's resources must be freed using " { $link dispose } ".\n\nExample:" }
|
||||
{ $code <"
|
||||
COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
|
||||
HRESULT returnOK ( )
|
||||
HRESULT returnError ( ) ;
|
||||
|
||||
COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
|
||||
int getX ( )
|
||||
void setX ( int newX ) ;
|
||||
|
||||
COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c}
|
||||
int xPlus ( int y )
|
||||
int xMulAdd ( int mul, int add ) ;
|
||||
|
||||
{
|
||||
{ "IInherited" {
|
||||
[ drop S_OK ] ! ISimple::returnOK
|
||||
[ drop E_FAIL ] ! ISimple::returnError
|
||||
[ x>> ] ! IInherited::getX
|
||||
[ >>x drop ] ! IInherited::setX
|
||||
} }
|
||||
{ "IUnrelated" {
|
||||
[ swap x>> + ] ! IUnrelated::xPlus
|
||||
[ spin x>> * + ] ! IUnrealted::xMulAdd
|
||||
} }
|
||||
} <com-wrapper>
|
||||
"> } ;
|
||||
|
||||
HELP: com-wrap
|
||||
{ $values { "object" "The factor object to wrap" } { "wrapper" "A " { $link com-wrapper } " object" } { "wrapped-object" "A COM object referencing " { $snippet "object" } } }
|
||||
{ $description "Allocates a COM object using the implementations in the " { $snippet "wrapper" } " object for the vtables and " { $snippet "object" } " for the \"this\" parameter. The COM object is allocated on the heap with an initial reference count of 1. The object will automatically deallocate itself when its reference count reaches 0 as a result of calling " { $link IUnknown::Release } " or " { $link com-release } " on it.\n\nNote that if " { $snippet "wrapper" } " implements multiple interfaces, you cannot count on the returned COM object pointer implementing any particular interface beyond " { $snippet "IUnknown" } ". You will need to use " { $link com-query-interface } " or " { $link IUnknown::QueryInterface } " to ask the object for the particular interface you need." } ;
|
||||
|
||||
HELP: com-wrapper
|
||||
{ $class-description "The tuple class used to store COM wrapper information. Objects of this class should be treated as opaque by user code. A com-wrapper can be constructed using the " { $link <com-wrapper> } " constructor and applied to a Factor object using " { $link com-wrap } "." } ;
|
||||
|
|
@ -0,0 +1,111 @@
|
|||
USING: alien alien.c-types windows.com.syntax
|
||||
windows.com.syntax.private windows.com continuations kernel
|
||||
sequences.lib namespaces windows.ole32 libc
|
||||
assocs accessors arrays sequences quotations combinators
|
||||
math combinators.lib words compiler.units ;
|
||||
IN: windows.com.wrapper
|
||||
|
||||
TUPLE: com-wrapper vtbls freed? ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: +wrapped-objects+
|
||||
+wrapped-objects+ get-global
|
||||
[ H{ } +wrapped-objects+ set-global ]
|
||||
unless
|
||||
|
||||
: com-unwrap ( wrapped -- object )
|
||||
+wrapped-objects+ get-global at*
|
||||
[ "invalid COM wrapping pointer" throw ] unless ;
|
||||
|
||||
: (free-wrapped-object) ( wrapped -- )
|
||||
[ +wrapped-objects+ get-global delete-at ] keep
|
||||
free ;
|
||||
|
||||
: (make-query-interface) ( interfaces -- quot )
|
||||
[
|
||||
[ swap 16 memory>byte-array ] %
|
||||
[
|
||||
>r find-com-interface-definition family-tree
|
||||
r> 1quotation [ >r iid>> r> 2array ] curry map
|
||||
] map-index concat
|
||||
[ f ] add ,
|
||||
\ case ,
|
||||
"void*" heap-size
|
||||
[ * rot <displaced-alien> com-add-ref 0 rot set-void*-nth S_OK ]
|
||||
curry ,
|
||||
[ nip f 0 rot set-void*-nth E_NOINTERFACE ] ,
|
||||
\ if* ,
|
||||
] [ ] make ;
|
||||
|
||||
: (make-add-ref) ( interfaces -- quot )
|
||||
length "void*" heap-size * [ swap <displaced-alien>
|
||||
0 over ulong-nth
|
||||
1+ [ 0 rot set-ulong-nth ] keep
|
||||
] curry ;
|
||||
|
||||
: (make-release) ( interfaces -- quot )
|
||||
length "void*" heap-size * [ over <displaced-alien>
|
||||
0 over ulong-nth
|
||||
1- [ 0 rot set-ulong-nth ] keep
|
||||
dup zero? [ swap (free-wrapped-object) ] [ nip ] if
|
||||
] curry ;
|
||||
|
||||
: (make-iunknown-methods) ( interfaces -- quots )
|
||||
[ (make-query-interface) ]
|
||||
[ (make-add-ref) ]
|
||||
[ (make-release) ] tri
|
||||
3array ;
|
||||
|
||||
: (thunk) ( n -- quot )
|
||||
dup 0 =
|
||||
[ drop [ ] ]
|
||||
[ "void*" heap-size neg * [ swap <displaced-alien> ] curry ]
|
||||
if ;
|
||||
|
||||
: (thunked-quots) ( quots iunknown-methods thunk -- quots' )
|
||||
[ [ swap 2array ] curry map swap ] keep
|
||||
[ com-unwrap ] compose [ swap 2array ] curry map append ;
|
||||
|
||||
: compile-alien-callback ( return parameters abi quot -- alien )
|
||||
[ alien-callback ] 4 ncurry
|
||||
[ gensym [ swap define ] keep ] with-compilation-unit
|
||||
execute ;
|
||||
|
||||
: (make-vtbl) ( interface-name quots iunknown-methods n -- )
|
||||
(thunk) (thunked-quots)
|
||||
swap find-com-interface-definition family-tree-functions [
|
||||
{ return>> parameters>> } get-slots
|
||||
dup length 1- roll [
|
||||
first dup empty?
|
||||
[ 2drop [ ] ]
|
||||
[ swap [ ndip ] 2curry ]
|
||||
if
|
||||
] [ second ] bi compose
|
||||
"stdcall" swap compile-alien-callback
|
||||
] 2map >c-void*-array [ byte-length malloc ] keep
|
||||
over byte-array>memory ;
|
||||
|
||||
: (make-vtbls) ( implementations -- vtbls )
|
||||
dup [ first ] map (make-iunknown-methods)
|
||||
[ >r >r first2 r> r> swap (make-vtbl) ] curry map-index ;
|
||||
|
||||
: (malloc-wrapped-object) ( wrapper -- wrapped-object )
|
||||
vtbls>> length "void*" heap-size *
|
||||
[ "ulong" heap-size + malloc ] keep
|
||||
over <displaced-alien>
|
||||
1 0 rot set-ulong-nth ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <com-wrapper> ( implementations -- wrapper )
|
||||
(make-vtbls) f com-wrapper construct-boa ;
|
||||
|
||||
M: com-wrapper dispose
|
||||
t >>freed?
|
||||
vtbls>> [ free ] each ;
|
||||
|
||||
: com-wrap ( object wrapper -- wrapped-object )
|
||||
dup (malloc-wrapped-object) >r vtbls>> r>
|
||||
[ [ set-void*-nth ] curry each-index ] keep
|
||||
[ +wrapped-objects+ get-global set-at ] keep ;
|
||||
|
|
@ -0,0 +1,68 @@
|
|||
USING: windows.com windows.com.wrapper combinators
|
||||
windows.kernel32 windows.ole32 windows.shell32 kernel accessors
|
||||
prettyprint namespaces ui.tools.listener ui.tools.workspace
|
||||
alien.c-types alien sequences math ;
|
||||
IN: windows.dragdrop-listener
|
||||
|
||||
: filenames-from-hdrop ( hdrop -- filenames )
|
||||
dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files
|
||||
[
|
||||
2dup f 0 DragQueryFile 1+ ! get size of filename buffer
|
||||
dup "WCHAR" <c-array>
|
||||
[ swap DragQueryFile drop ] keep
|
||||
alien>u16-string
|
||||
] with map ;
|
||||
|
||||
: filenames-from-data-object ( data-object -- filenames )
|
||||
"FORMATETC" <c-object>
|
||||
CF_HDROP over set-FORMATETC-cfFormat
|
||||
f over set-FORMATETC-ptd
|
||||
DVASPECT_CONTENT over set-FORMATETC-dwAspect
|
||||
-1 over set-FORMATETC-lindex
|
||||
TYMED_HGLOBAL over set-FORMATETC-tymed
|
||||
"STGMEDIUM" <c-object>
|
||||
[ IDataObject::GetData ] keep swap succeeded? [
|
||||
dup STGMEDIUM-data
|
||||
[ filenames-from-hdrop ] with-global-lock
|
||||
swap ReleaseStgMedium
|
||||
] [ drop f ] if ;
|
||||
|
||||
TUPLE: listener-dragdrop hWnd last-drop-effect ;
|
||||
|
||||
: <listener-dragdrop> ( hWnd -- object )
|
||||
DROPEFFECT_NONE listener-dragdrop construct-boa ;
|
||||
|
||||
SYMBOL: +listener-dragdrop-wrapper+
|
||||
{
|
||||
{ "IDropTarget" {
|
||||
[ ! DragEnter
|
||||
>r 2drop
|
||||
filenames-from-data-object
|
||||
length 1 = [ DROPEFFECT_COPY ] [ DROPEFFECT_NONE ] if
|
||||
dup 0 r> set-ulong-nth
|
||||
>>last-drop-effect drop
|
||||
S_OK
|
||||
] [ ! DragOver
|
||||
>r 2drop last-drop-effect>> 0 r> set-ulong-nth
|
||||
S_OK
|
||||
] [ ! DragLeave
|
||||
drop S_OK
|
||||
] [ ! Drop
|
||||
>r 2drop nip
|
||||
filenames-from-data-object
|
||||
dup length 1 = [
|
||||
first unparse [ "USE: parser " % % " run-file" % ] "" make
|
||||
eval-listener
|
||||
DROPEFFECT_COPY
|
||||
] [ 2drop DROPEFFECT_NONE ] if
|
||||
0 r> set-ulong-nth
|
||||
S_OK
|
||||
]
|
||||
} }
|
||||
} <com-wrapper> +listener-dragdrop-wrapper+ set-global
|
||||
|
||||
: dragdrop-listener-window ( -- )
|
||||
get-workspace parent>> handle>> hWnd>>
|
||||
dup <listener-dragdrop>
|
||||
+listener-dragdrop-wrapper+ get-global com-wrap
|
||||
[ RegisterDragDrop ole32-error ] with-com-interface ;
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2005, 2006 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.syntax windows.types ;
|
||||
USING: alien alien.syntax kernel windows.types ;
|
||||
IN: windows.kernel32
|
||||
|
||||
: MAX_PATH 260 ; inline
|
||||
|
|
@ -1573,3 +1573,6 @@ FUNCTION: BOOL WriteProcessMemory ( HANDLE hProcess, void* lpBaseAddress, void*
|
|||
! FUNCTION: WriteTapemark
|
||||
! FUNCTION: WTSGetActiveConsoleSessionId
|
||||
! FUNCTION: ZombifyActCtx
|
||||
|
||||
: with-global-lock ( HGLOBAL quot -- )
|
||||
swap [ GlobalLock swap call ] keep GlobalUnlock drop ; inline
|
||||
|
|
|
|||
|
|
@ -4,13 +4,7 @@ IN: windows.ole32
|
|||
|
||||
LIBRARY: ole32
|
||||
|
||||
C-STRUCT: GUID
|
||||
{ "DWORD" "part1" }
|
||||
{ "DWORD" "part2" }
|
||||
{ "DWORD" "part3" }
|
||||
{ "DWORD" "part4" } ;
|
||||
|
||||
TYPEDEF: void* REFGUID
|
||||
TYPEDEF: GUID* REFGUID
|
||||
TYPEDEF: void* LPUNKNOWN
|
||||
TYPEDEF: wchar_t* LPOLESTR
|
||||
TYPEDEF: wchar_t* LPCOLESTR
|
||||
|
|
@ -25,6 +19,7 @@ FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
|
|||
|
||||
: S_OK 0 ; inline
|
||||
: S_FALSE 1 ; inline
|
||||
: E_NOINTERFACE HEX: 80004002 ; inline
|
||||
: E_FAIL HEX: 80004005 ; inline
|
||||
: E_INVALIDARG HEX: 80070057 ; inline
|
||||
|
||||
|
|
@ -40,11 +35,92 @@ FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
|
|||
: DD_DEFDRAGDELAY 200 ; inline
|
||||
: DD_DEFDRAGMINDIST 2 ; inline
|
||||
|
||||
: ole32-error ( n -- )
|
||||
dup S_OK = [
|
||||
: CF_TEXT 1 ; inline
|
||||
: CF_BITMAP 2 ; inline
|
||||
: CF_METAFILEPICT 3 ; inline
|
||||
: CF_SYLK 4 ; inline
|
||||
: CF_DIF 5 ; inline
|
||||
: CF_TIFF 6 ; inline
|
||||
: CF_OEMTEXT 7 ; inline
|
||||
: CF_DIB 8 ; inline
|
||||
: CF_PALETTE 9 ; inline
|
||||
: CF_PENDATA 10 ; inline
|
||||
: CF_RIFF 11 ; inline
|
||||
: CF_WAVE 12 ; inline
|
||||
: CF_UNICODETEXT 13 ; inline
|
||||
: CF_ENHMETAFILE 14 ; inline
|
||||
: CF_HDROP 15 ; inline
|
||||
: CF_LOCALE 16 ; inline
|
||||
: CF_MAX 17 ; inline
|
||||
|
||||
: CF_OWNERDISPLAY HEX: 0080 ; inline
|
||||
: CF_DSPTEXT HEX: 0081 ; inline
|
||||
: CF_DSPBITMAP HEX: 0082 ; inline
|
||||
: CF_DSPMETAFILEPICT HEX: 0083 ; inline
|
||||
: CF_DSPENHMETAFILE HEX: 008E ; inline
|
||||
|
||||
: DVASPECT_CONTENT 1 ; inline
|
||||
: DVASPECT_THUMBNAIL 2 ; inline
|
||||
: DVASPECT_ICON 4 ; inline
|
||||
: DVASPECT_DOCPRINT 8 ; inline
|
||||
|
||||
: TYMED_HGLOBAL 1 ; inline
|
||||
: TYMED_FILE 2 ; inline
|
||||
: TYMED_ISTREAM 4 ; inline
|
||||
: TYMED_ISTORAGE 8 ; inline
|
||||
: TYMED_GDI 16 ; inline
|
||||
: TYMED_MFPICT 32 ; inline
|
||||
: TYMED_ENHMF 64 ; inline
|
||||
: TYMED_NULL 0 ; inline
|
||||
|
||||
C-STRUCT: DVTARGETDEVICE
|
||||
{ "DWORD" "tdSize" }
|
||||
{ "WORD" "tdDriverNameOffset" }
|
||||
{ "WORD" "tdDeviceNameOffset" }
|
||||
{ "WORD" "tdPortNameOffset" }
|
||||
{ "WORD" "tdExtDevmodeOffset" }
|
||||
{ "BYTE[1]" "tdData" } ;
|
||||
|
||||
TYPEDEF: WORD CLIPFORMAT
|
||||
TYPEDEF: POINT POINTL
|
||||
|
||||
C-STRUCT: FORMATETC
|
||||
{ "CLIPFORMAT" "cfFormat" }
|
||||
{ "DVTARGETDEVICE*" "ptd" }
|
||||
{ "DWORD" "dwAspect" }
|
||||
{ "LONG" "lindex" }
|
||||
{ "DWORD" "tymed" } ;
|
||||
TYPEDEF: FORMATETC* LPFORMATETC
|
||||
|
||||
C-STRUCT: STGMEDIUM
|
||||
{ "DWORD" "tymed" }
|
||||
{ "void*" "data" }
|
||||
{ "LPUNKNOWN" "punkForRelease" } ;
|
||||
TYPEDEF: STGMEDIUM* LPSTGMEDIUM
|
||||
|
||||
: COINIT_MULTITHREADED 0 ; inline
|
||||
: COINIT_APARTMENTTHREADED 2 ; inline
|
||||
: COINIT_DISABLE_OLE1DDE 4 ; inline
|
||||
: COINIT_SPEED_OVER_MEMORY 8 ; inline
|
||||
|
||||
FUNCTION: HRESULT OleInitialize ( void* reserved ) ;
|
||||
FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ;
|
||||
|
||||
FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;
|
||||
FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;
|
||||
FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
|
||||
|
||||
: succeeded? ( hresult -- ? )
|
||||
0 HEX: 7FFFFFFF between? ;
|
||||
|
||||
: ole32-error ( hresult -- )
|
||||
dup succeeded? [
|
||||
drop
|
||||
] [ (win32-error-string) throw ] if ;
|
||||
|
||||
: ole-initialize ( -- )
|
||||
f OleInitialize ole32-error ;
|
||||
|
||||
: guid= ( a b -- ? )
|
||||
IsEqualGUID c-bool> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -167,6 +167,15 @@ TYPEDEF: DWORD SHGDNF
|
|||
|
||||
TYPEDEF: ULONG SFGAOF
|
||||
|
||||
C-STRUCT: DROPFILES
|
||||
{ "DWORD" "pFiles" }
|
||||
{ "POINT" "pt" }
|
||||
{ "BOOL" "fNC" }
|
||||
{ "BOOL" "fWide" } ;
|
||||
TYPEDEF: DROPFILES* LPDROPFILES
|
||||
TYPEDEF: DROPFILES* LPCDROPFILES
|
||||
TYPEDEF: HANDLE HDROP
|
||||
|
||||
C-STRUCT: SHITEMID
|
||||
{ "USHORT" "cb" }
|
||||
{ "BYTE[1]" "abID" } ;
|
||||
|
|
@ -210,5 +219,6 @@ COM-INTERFACE: IShellFolder IUnknown {000214E6-0000-0000-C000-000000000046}
|
|||
|
||||
FUNCTION: HRESULT SHGetDesktopFolder ( IShellFolder** ppshf ) ;
|
||||
|
||||
FUNCTION: HRESULT StrRetToBufW ( STRRET *pstr, PCUITEMID_CHILD pidl, LPWSTR pszBuf, UINT cchBuf ) ;
|
||||
: StrRetToBuf StrRetToBufW ; inline
|
||||
FUNCTION: UINT DragQueryFileW ( HDROP hDrop, UINT iFile, LPWSTR lpszFile, UINT cch ) ;
|
||||
: DragQueryFile DragQueryFileW ; inline
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue