value-info >literal< ;
: possible-boolean-values ( info -- values )
- dup literal?>> [
- literal>> 1array
- ] [
- class>> {
- { [ dup null-class? ] [ { } ] }
- { [ dup true-class? ] [ { t } ] }
- { [ dup false-class? ] [ { f } ] }
- [ { t f } ]
- } cond nip
- ] if ;
+ class>> {
+ { [ dup null-class? ] [ { } ] }
+ { [ dup true-class? ] [ { t } ] }
+ { [ dup false-class? ] [ { f } ] }
+ [ { t f } ]
+ } cond nip ;
: node-value-info ( node value -- info )
swap info>> at* [ drop null-info ] unless ;
[ t ] [ [ { float float } declare max ] { max } inlined? ] unit-test
[ f ] [ [ { float float } declare max ] { float-max } inlined? ] unit-test
+
+! Propagation should not call equal?, hashcode, etc on literals in user code
+[ V{ } ] [ [ 4 <reversed> [ 2drop ] with each ] final-info ] unit-test
+
+! Reduction
+[ 1 ] [ [ 4 <reversed> [ nth-unsafe ] [ ] unless ] final-info length ] unit-test
100 <buffer> "b" set
[ 1000 "b" get n>buffer >string ] must-fail
"b" get dispose
+
+"hello world" string>buffer "b" set
+[ "hello" CHAR: \s ] [ " " "b" get buffer-until [ >string ] dip ] unit-test
+"b" get dispose
! Copyright (C) 2004, 2005 Mackenzie Straight.
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.accessors alien.c-types
alien.data alien.syntax kernel libc math sequences byte-arrays
bi ; inline
: search-buffer-until ( pos fill ptr separators -- n )
- [ [ swap alien-unsigned-1 ] dip member-eq? ] 2curry find-from drop ; inline
+ [ iota ] 2dip
+ [ [ swap alien-unsigned-1 ] dip member-eq? ] 2curry
+ find-from drop ; inline
: finish-buffer-until ( buffer n -- byte-array separator )
[
ret win32-error-string throw
] [
names names-length *uint ushort heap-size * head
- utf16n alien>string CHAR: \0 split
+ utf16n alien>string { CHAR: \0 } split
] if ;
: find-first-volume ( -- string handle )
FUNCTOR: define-array ( T -- )
A DEFINES-CLASS ${T}-array
-S DEFINES-CLASS ${T}-sequence
<A> DEFINES <${A}>
(A) DEFINES (${A})
<direct-A> DEFINES <direct-${A}>
WHERE
-MIXIN: S
-
TUPLE: A
{ underlying c-ptr read-only }
{ length array-capacity read-only } ;
V DEFINES-CLASS ${T}-vector
A IS ${T}-array
-S IS ${T}-sequence
<A> IS <${A}>
>V DEFERS >${V}
SYNTAX: V{ \ } [ >V ] parse-literal ;
INSTANCE: V growable
-INSTANCE: V S
;FUNCTOR
IN: ui.gadgets.search-tables.tests
-USING: ui.gadgets.search-tables sequences tools.test ;
+USING: ui.gadgets.search-tables ui.gadgets.tables ui.gadgets models
+arrays sequences tools.test ;
+
[ [ second ] <search-table> ] must-infer
+
+[ t ] [ f <model> trivial-renderer [ second ] <search-table> pref-dim pair? ] unit-test
action
hook
font
-gap
selection-color
focus-border-color
mouse-color
math.order namespaces parser parser.notes prettyprint
quotations random see sequences sequences.private slots
slots.private splitting strings summary threads tools.test
-vectors vocabs words words.symbol fry ;
+vectors vocabs words words.symbol fry literals ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
[ T{ bad-slot-value f "hi" fixnum } = ]
must-fail-with
-[ T{ declared-types f 0 "hi" } ]
-[ 0.0 "hi" declared-types boa ] unit-test
+! Check fixnum coercer
+[ 0 ] [ 0.0 "hi" declared-types boa n>> ] unit-test
+
+[ 0 ] [ declared-types new 0.0 >>n n>> ] unit-test
+
+! Check bignum coercer
+TUPLE: bignum-coercer { n bignum initial: $[ 0 >bignum ] } ;
+
+[ 13 bignum ] [ 13.5 bignum-coercer boa n>> dup class ] unit-test
+
+[ 13 bignum ] [ bignum-coercer new 13.5 >>n n>> dup class ] unit-test
+
+! Check float coercer
+TUPLE: float-coercer { n float } ;
+
+[ 13.0 float ] [ 13 float-coercer boa n>> dup class ] unit-test
+
+[ 13.0 float ] [ float-coercer new 13 >>n n>> dup class ] unit-test
+
+! Check integer coercer
+TUPLE: integer-coercer { n integer } ;
+
+[ 13 fixnum ] [ 13.5 integer-coercer boa n>> dup class ] unit-test
+
+[ 13 fixnum ] [ integer-coercer new 13.5 >>n n>> dup class ] unit-test
: foo ( a b -- c ) declared-types boa ;
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions hashtables kernel kernel.private math
namespaces make sequences sequences.private strings vectors
: class-size ( class -- n )
superclasses [ "slots" word-prop length ] map-sum ;
-: (instance-check-quot) ( class -- quot )
- [
- \ dup ,
- [ "predicate" word-prop % ]
- [ [ literalize , \ bad-slot-value , ] [ ] make , ] bi
- \ unless ,
- ] [ ] make ;
-
-: (fixnum-check-quot) ( class -- quot )
- (instance-check-quot) fixnum "coercer" word-prop prepend ;
-
-: instance-check-quot ( class -- quot )
- {
- { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
- { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
- { [ dup \ fixnum class<= ] [ (fixnum-check-quot) ] }
- [ (instance-check-quot) ]
- } cond ;
-
: boa-check-quot ( class -- quot )
all-slots [ class>> instance-check-quot ] map spread>quot
f like ;
USING: arrays debugger.threads destructors io io.directories
-io.encodings.ascii io.encodings.binary
-io.files io.files.private io.files.temp io.files.unique kernel
-make math sequences system threads tools.test generic.single
-io.encodings.8-bit.latin1 ;
+io.encodings.ascii io.encodings.binary io.encodings.string
+io.encodings.8-bit.latin1 io.files io.files.private
+io.files.temp io.files.unique kernel make math sequences system
+threads tools.test generic.single ;
IN: io.files.tests
[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
[ read1 ] with-file-reader >fixnum
] unit-test
+[
+ "This" CHAR: \s
+] [
+ "vocab:io/test/read-until-test.txt" ascii
+ [ " " read-until ] with-file-reader
+] unit-test
+
+[
+ "This" CHAR: \s
+] [
+ "vocab:io/test/read-until-test.txt" binary
+ [ " " read-until [ ascii decode ] dip ] with-file-reader
+] unit-test
+
[ ] [
"It seems Jobs has lost his grasp on reality again.\n"
"separator-test.txt" temp-file latin1 set-file-contents
--- /dev/null
+This is a text file
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays kernel kernel.private math namespaces
make sequences strings effects generic generic.standard
ERROR: bad-slot-value value class ;
-: writer-quot/object ( slot-spec -- )
- offset>> , \ set-slot , ;
-
-: writer-quot/coerce ( slot-spec -- )
- [ class>> "coercer" word-prop [ dip ] curry % ]
- [ offset>> , \ set-slot , ]
- bi ;
-
-: writer-quot/check ( slot-spec -- )
- [ offset>> , ]
+: (instance-check-quot) ( class -- quot )
[
- \ pick ,
- dup class>> "predicate" word-prop %
- [ set-slot ] ,
- class>> [ 2nip bad-slot-value ] curry [ ] like ,
- \ if ,
- ]
- bi ;
+ \ dup ,
+ [ "predicate" word-prop % ]
+ [ [ bad-slot-value ] curry , ] bi
+ \ unless ,
+ ] [ ] make ;
-: writer-quot/fixnum ( slot-spec -- )
- [ [ >fixnum ] dip ] % writer-quot/check ;
+: instance-check-quot ( class -- quot )
+ {
+ { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
+ { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
+ { [ dup integer bootstrap-word eq? ] [ drop [ >integer ] ] }
+ [ (instance-check-quot) ]
+ } cond ;
GENERIC# writer-quot 1 ( class slot-spec -- quot )
M: object writer-quot
- nip [
- {
- { [ dup class>> object bootstrap-word eq? ] [ writer-quot/object ] }
- { [ dup class>> "coercer" word-prop ] [ writer-quot/coerce ] }
- { [ dup class>> fixnum bootstrap-word class<= ] [ writer-quot/fixnum ] }
- [ writer-quot/check ]
- } cond
- ] [ ] make ;
+ nip
+ [ class>> instance-check-quot dup empty? [ [ dip ] curry ] unless ]
+ [ offset>> [ set-slot ] curry ]
+ bi append ;
: writer-props ( slot-spec -- assoc )
"writing" associate ;
! (c)2009 Joe Groff bsd license
USING: accessors alien alien.c-types arrays byte-arrays
combinators destructors gpu kernel locals math opengl opengl.gl
-ui.gadgets.worlds variants ;
+typed ui.gadgets.worlds variants ;
IN: gpu.buffers
VARIANT: buffer-upload-pattern
} case ; inline
: get-buffer-int ( target enum -- value )
- 0 <int> [ glGetBufferParameteriv ] keep *int ;
+ 0 <int> [ glGetBufferParameteriv ] keep *int ; inline
: bind-buffer ( buffer -- target )
- [ kind>> gl-target dup ] [ handle>> glBindBuffer ] bi ;
+ [ kind>> gl-target dup ] [ handle>> glBindBuffer ] bi ; inline
PRIVATE>
UNION: gpu-data-ptr buffer-ptr c-ptr ;
-: buffer-size ( buffer -- size )
+TYPED: buffer-size ( buffer: buffer -- size: integer )
bind-buffer GL_BUFFER_SIZE get-buffer-int ;
: buffer-ptr>range ( buffer-ptr -- buffer-range )
2dup [ buffer-size ] dip -
buffer-range boa ; inline
-:: allocate-buffer ( buffer size initial-data -- )
+TYPED:: allocate-buffer ( buffer: buffer size: integer initial-data -- )
buffer bind-buffer :> target
target size initial-data buffer gl-buffer-usage glBufferData ;
-: <buffer> ( upload usage kind size initial-data -- buffer )
+TYPED: <buffer> ( upload: buffer-upload-pattern
+ usage: buffer-usage-pattern
+ kind: buffer-kind
+ size: integer
+ initial-data
+ --
+ buffer: buffer )
[ [ gen-gl-buffer ] 3dip buffer boa dup ] 2dip allocate-buffer
window-resource ;
-: byte-array>buffer ( byte-array upload usage kind -- buffer )
+TYPED: byte-array>buffer ( byte-array
+ upload: buffer-upload-pattern
+ usage: buffer-usage-pattern
+ kind: buffer-kind
+ --
+ buffer: buffer )
[ ] 3curry dip
[ byte-length ] [ ] bi <buffer> ;
-:: update-buffer ( buffer-ptr size data -- )
+TYPED:: update-buffer ( buffer-ptr: buffer-ptr size: integer data -- )
buffer-ptr buffer>> :> buffer
buffer bind-buffer :> target
target buffer-ptr offset>> size data glBufferSubData ;
-:: read-buffer ( buffer-ptr size -- data )
+TYPED:: read-buffer ( buffer-ptr: buffer-ptr size: integer -- data: byte-array )
buffer-ptr buffer>> :> buffer
buffer bind-buffer :> target
size <byte-array> :> data
target buffer-ptr offset>> size data glGetBufferSubData
data ;
-:: copy-buffer ( to-buffer-ptr from-buffer-ptr size -- )
+TYPED:: copy-buffer ( to-buffer-ptr: buffer-ptr from-buffer-ptr: buffer-ptr size: integer -- )
GL_COPY_WRITE_BUFFER to-buffer-ptr buffer>> glBindBuffer
GL_COPY_READ_BUFFER from-buffer-ptr buffer>> glBindBuffer
[ sobel>> framebuffer>> ] [ dim>> ] bi resize-framebuffer ;
M: bunny-world pref-dim* drop { 1024 768 } ;
-M: bunny-world tick-length drop 1000000 30 /i ;
+M: bunny-world tick-length drop 1000000 60 /i ;
M: bunny-world wasd-movement-speed drop 1/160. ;
M: bunny-world wasd-near-plane drop 1/32. ;
M: bunny-world wasd-far-plane drop 256.0 ;
} <render-set> render ;
M: raytrace-world pref-dim* drop { 1024 768 } ;
-M: raytrace-world tick-length drop 1000000 30 /i ;
+M: raytrace-world tick-length drop 1000000 60 /i ;
M: raytrace-world wasd-movement-speed drop 1/4. ;
: raytrace-window ( -- )
destructors gpu gpu.buffers gpu.private gpu.textures
gpu.textures.private images kernel locals math math.rectangles opengl
opengl.framebuffers opengl.gl opengl.textures sequences
-specialized-arrays ui.gadgets.worlds variants ;
+specialized-arrays typed ui.gadgets.worlds variants ;
SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: uint
IN: gpu.framebuffers
PRIVATE>
-:: allocate-renderbuffer ( renderbuffer dim -- )
+TYPED:: allocate-renderbuffer ( renderbuffer: renderbuffer dim -- )
GL_RENDERBUFFER renderbuffer handle>> glBindRenderbuffer
GL_RENDERBUFFER
renderbuffer samples>> dup zero?
[ renderbuffer texture-gl-internal-format dim first2 glRenderbufferStorageMultisample ]
if ;
-:: renderbuffer-dim ( renderbuffer -- dim )
+TYPED:: renderbuffer-dim ( renderbuffer: renderbuffer -- dim: array )
GL_RENDERBUFFER renderbuffer handle>> glBindRenderbuffer
GL_RENDERBUFFER_WIDTH get-framebuffer-int
GL_RENDERBUFFER_HEIGHT get-framebuffer-int 2array ;
-: <renderbuffer> ( component-order component-type samples dim -- renderbuffer )
+TYPED: <renderbuffer> ( component-order: component-order
+ component-type: component-type
+ samples
+ dim
+ --
+ renderbuffer )
[ [ gen-renderbuffer ] 3dip renderbuffer boa dup ] dip
[ allocate-renderbuffer ] [ drop ] if*
window-resource ;
C: <framebuffer-rect> framebuffer-rect
-: framebuffer-attachment-at ( framebuffer attachment-ref -- attachment )
+TYPED: framebuffer-attachment-at ( framebuffer: framebuffer
+ attachment-ref: attachment-ref
+ --
+ attachment: framebuffer-attachment )
{
{ default-attachment [ color-attachments>> first ] }
{ color-attachment [ swap color-attachments>> nth ] }
PRIVATE>
-: <full-framebuffer-rect> ( framebuffer attachment -- framebuffer-rect )
+TYPED: <full-framebuffer-rect> ( framebuffer: any-framebuffer
+ attachment: attachment-ref
+ --
+ framebuffer-rect: framebuffer-rect )
2dup framebuffer-attachment-at
{ 0 0 } swap framebuffer-attachment-dim <rect>
<framebuffer-rect> ;
-: resize-framebuffer ( framebuffer dim -- )
+TYPED: resize-framebuffer ( framebuffer: framebuffer dim -- )
[ allocate-framebuffer-attachment ] curry each-attachment ;
:: attach-framebuffer-attachments ( framebuffer -- )
GL_DRAW_FRAMEBUFFER framebuffer handle>> glBindFramebuffer
- framebuffer [ bind-framebuffer-attachment ] each-attachment-target ;
+ framebuffer [ bind-framebuffer-attachment ] each-attachment-target ; inline
M: framebuffer dispose
[ [ delete-framebuffer ] when* f ] change-handle drop ;
-: dispose-framebuffer-attachments ( framebuffer -- )
+TYPED: dispose-framebuffer-attachments ( framebuffer: framebuffer -- )
[ [ dispose ] when* ] each-attachment ;
-: <framebuffer> ( color-attachments depth-attachment stencil-attachment dim -- framebuffer )
+: <framebuffer> ( color-attachments
+ depth-attachment: framebuffer-attachment
+ stencil-attachment: framebuffer-attachment
+ dim
+ --
+ framebuffer: framebuffer )
[ [ 0 ] 3dip framebuffer boa dup ] dip
[ resize-framebuffer ] [ drop ] if*
gen-framebuffer >>handle
dup attach-framebuffer-attachments
window-resource ;
-:: clear-framebuffer-attachment ( framebuffer attachment-ref value -- )
+TYPED:: clear-framebuffer-attachment ( framebuffer: any-framebuffer
+ attachment-ref: attachment-ref
+ value -- )
GL_DRAW_FRAMEBUFFER framebuffer framebuffer-handle glBindFramebuffer
attachment-ref {
{ system-attachment [| side face |
} match ;
: clear-framebuffer ( framebuffer alist -- )
- [ first2 clear-framebuffer-attachment ] with each ;
+ [ first2 clear-framebuffer-attachment ] with each ; inline
-:: read-framebuffer-to ( framebuffer-rect gpu-data-ptr -- )
+TYPED:: read-framebuffer-to ( framebuffer-rect: framebuffer-rect
+ gpu-data-ptr -- )
GL_READ_FRAMEBUFFER framebuffer-rect framebuffer>> framebuffer-handle glBindFramebuffer
framebuffer-rect [ framebuffer>> ] [ attachment>> ] bi gl-attachment glReadBuffer
framebuffer-rect rect>> [ loc>> first2 ] [ dim>> first2 ] bi
gpu-data-ptr pixel-pack-buffer [ glReadPixels ] with-gpu-data-ptr ;
: read-framebuffer ( framebuffer-rect -- byte-array )
- dup framebuffer-rect-size <byte-array> [ read-framebuffer-to ] keep ;
+ dup framebuffer-rect-size <byte-array> [ read-framebuffer-to ] keep ; inline
-: read-framebuffer-image ( framebuffer-rect -- image )
+TYPED: read-framebuffer-image ( framebuffer-rect -- image )
[ <image> ] dip {
[ rect>> dim>> >>dim ]
[
[ read-framebuffer >>bitmap ]
} cleave ;
-:: copy-framebuffer ( to-fb-rect from-fb-rect depth? stencil? filter -- )
+TYPED:: copy-framebuffer ( to-fb-rect: framebuffer-rect
+ from-fb-rect: framebuffer-rect
+ depth? stencil? filter: texture-filter -- )
GL_DRAW_FRAMEBUFFER to-fb-rect framebuffer>> framebuffer-handle glBindFramebuffer
to-fb-rect [ framebuffer>> ] [ attachment>> ] bi gl-attachment glDrawBuffer
GL_READ_FRAMEBUFFER from-fb-rect framebuffer>> framebuffer-handle glBindFramebuffer
{ ubyte-indexes [ GL_UNSIGNED_BYTE ] }
{ ushort-indexes [ GL_UNSIGNED_SHORT ] }
{ uint-indexes [ GL_UNSIGNED_INT ] }
- } case ;
+ } case ; inline
: gl-primitive-mode ( primitive-mode -- gl-primitive-mode )
{
{ triangles-mode [ GL_TRIANGLES ] }
{ triangle-strip-mode [ GL_TRIANGLE_STRIP ] }
{ triangle-fan-mode [ GL_TRIANGLE_FAN ] }
- } case ;
+ } case ; inline
GENERIC: render-vertex-indexes ( primitive-mode vertex-indexes -- )
opengl opengl.gl opengl.shaders parser quotations sequences
specialized-arrays splitting strings tr ui.gadgets.worlds
variants vectors vocabs vocabs.loader vocabs.parser words
-words.constant half-floats ;
+words.constant half-floats typed ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: void*
gen-vertex-array
[ glBindVertexArray [ first2 bind-vertex-format ] with each ]
[ -rot [ first buffer>> ] map vertex-array boa ] 3bi
- window-resource ;
+ window-resource ; inline
-: buffer>vertex-array ( vertex-buffer program-instance format -- vertex-array )
+TYPED: buffer>vertex-array ( vertex-buffer: buffer
+ program-instance: program-instance
+ format: vertex-format
+ --
+ vertex-array: vertex-array )
[ swap ] dip
[ 0 <buffer-ptr> ] dip 2array 1array <vertex-array> ; inline
-: vertex-array-buffer ( vertex-array -- vertex-buffer )
+TYPED: vertex-array-buffer ( vertex-array: vertex-array -- vertex-buffer: buffer )
vertex-buffers>> first ;
TUPLE: compile-shader-error shader log ;
PRIVATE>
-:: refresh-program ( program -- )
+TYPED:: refresh-program ( program: program -- )
program shaders>> [ refresh-shader-source ] each
program instances>> [| world old-instance |
old-instance valid-handle? [
] assoc-each
reset-memos ;
-: <shader-instance> ( shader -- instance )
+TYPED: <shader-instance> ( shader: shader -- instance: shader-instance )
[ find-shader-instance dup world get ] keep instances>> set-at ;
-: <program-instance> ( program -- instance )
+TYPED: <program-instance> ( program: program -- instance: program-instance )
[ find-program-instance dup world get ] keep instances>> set-at ;
<PRIVATE
! (c)2009 Joe Groff bsd license
USING: accessors alien.c-types alien.data arrays byte-arrays
combinators gpu kernel literals math math.rectangles opengl
-opengl.gl sequences variants specialized-arrays ;
+opengl.gl sequences typed variants specialized-arrays ;
QUALIFIED-WITH: alien.c-types c
FROM: math => float ;
SPECIALIZED-ARRAY: int
PRIVATE>
-: get-viewport-state ( -- viewport-state )
+TYPED: get-viewport-state ( -- viewport-state: viewport-state )
GL_VIEWPORT get-gl-rect <viewport-state> ;
-: get-scissor-state ( -- scissor-state )
+TYPED: get-scissor-state ( -- scissor-state: scissor-state )
GL_SCISSOR_TEST get-gl-bool
[ GL_SCISSOR_BOX get-gl-rect ] [ f ] if
<scissor-state> ;
-: get-multisample-state ( -- multisample-state )
+TYPED: get-multisample-state ( -- multisample-state: multisample-state )
GL_MULTISAMPLE gl-enabled?
GL_SAMPLE_ALPHA_TO_COVERAGE gl-enabled?
GL_SAMPLE_ALPHA_TO_ONE gl-enabled?
] [ f f ] if
<multisample-state> ;
-: get-stencil-state ( -- stencil-state )
+TYPED: get-stencil-state ( -- stencil-state: stencil-state )
GL_STENCIL_TEST gl-enabled? [
GL_STENCIL_REF get-gl-int
GL_STENCIL_VALUE_MASK get-gl-int
] [ f f ] if
<stencil-state> ;
-: get-depth-range-state ( -- depth-range-state )
+TYPED: get-depth-range-state ( -- depth-range-state: depth-range-state )
GL_DEPTH_RANGE 2 get-gl-floats first2 <depth-range-state> ;
-: get-depth-state ( -- depth-state )
+TYPED: get-depth-state ( -- depth-state: depth-state )
GL_DEPTH_TEST gl-enabled?
[ GL_DEPTH_FUNC get-gl-int gl-comparison> ] [ f ] if
<depth-state> ;
-: get-blend-state ( -- blend-state )
+TYPED: get-blend-state ( -- blend-state: blend-state )
GL_BLEND gl-enabled? [
GL_BLEND_COLOR 4 get-gl-floats
] [ f f f ] if
<blend-state> ;
-: get-mask-state ( -- mask-state )
+TYPED: get-mask-state ( -- mask-state: mask-state )
GL_COLOR_WRITEMASK 4 get-gl-bools
GL_DEPTH_WRITEMASK get-gl-bool
GL_STENCIL_WRITEMASK get-gl-int
GL_STENCIL_BACK_WRITEMASK get-gl-int
<mask-state> ;
-: get-triangle-cull-state ( -- triangle-cull-state )
+TYPED: get-triangle-cull-state ( -- triangle-cull-state: triangle-cull-state )
GL_FRONT_FACE get-gl-int gl-triangle-face>
GL_CULL_FACE gl-enabled?
[ GL_CULL_FACE_MODE get-gl-int gl-triangle-cull> ]
[ f ] if
<triangle-cull-state> ;
-: get-triangle-state ( -- triangle-state )
+TYPED: get-triangle-state ( -- triangle-state: triangle-state )
GL_POLYGON_MODE 2 get-gl-ints
first2 [ gl-triangle-mode> ] bi@
GL_POLYGON_SMOOTH gl-enabled?
<triangle-state> ;
-: get-point-state ( -- point-state )
+TYPED: get-point-state ( -- point-state: point-state )
GL_VERTEX_PROGRAM_POINT_SIZE gl-enabled?
[ f ] [ GL_POINT_SIZE get-gl-float ] if
GL_POINT_SPRITE_COORD_ORIGIN get-gl-int gl-point-sprite-origin>
GL_POINT_FADE_THRESHOLD_SIZE get-gl-float
<point-state> ;
-: get-line-state ( -- line-state )
+TYPED: get-line-state ( -- line-state: line-state )
GL_LINE_WIDTH get-gl-float
GL_LINE_SMOOTH gl-enabled?
<line-state> ;
USING: accessors alien.c-types arrays byte-arrays combinators
destructors fry gpu gpu.buffers images kernel locals math
opengl opengl.gl opengl.textures sequences
-specialized-arrays ui.gadgets.worlds variants ;
+specialized-arrays typed ui.gadgets.worlds variants ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: gpu.textures
GENERIC: texture-object ( texture-data-target -- texture )
M: cube-map-face texture-object
- texture>> ;
+ texture>> ; inline
M: texture texture-object
- ;
+ ; inline
: gl-wrap ( wrap -- gl-wrap )
{
{ clamp-texcoord-to-border [ GL_CLAMP_TO_BORDER ] }
{ repeat-texcoord [ GL_REPEAT ] }
{ repeat-texcoord-mirrored [ GL_MIRRORED_REPEAT ] }
- } case ;
+ } case ; inline
: set-texture-gl-wrap ( target wraps -- )
dup sequence? [ 1array ] unless 3 over last pad-tail {
[ [ GL_TEXTURE_WRAP_S ] dip first gl-wrap glTexParameteri ]
[ [ GL_TEXTURE_WRAP_T ] dip second gl-wrap glTexParameteri ]
[ [ GL_TEXTURE_WRAP_R ] dip third gl-wrap glTexParameteri ]
- } 2cleave ;
+ } 2cleave ; inline
: gl-mag-filter ( filter -- gl-filter )
{
{ filter-nearest [ GL_NEAREST ] }
{ filter-linear [ GL_LINEAR ] }
- } case ;
+ } case ; inline
: gl-min-filter ( filter mipmap-filter -- gl-filter )
2array {
{ { filter-linear filter-nearest } [ GL_LINEAR_MIPMAP_NEAREST ] }
{ { filter-linear filter-linear } [ GL_LINEAR_MIPMAP_LINEAR ] }
{ { filter-nearest filter-linear } [ GL_NEAREST_MIPMAP_LINEAR ] }
- } case ;
+ } case ; inline
GENERIC: texture-gl-target ( texture -- target )
GENERIC: texture-data-gl-target ( texture -- target )
-M: texture-1d texture-gl-target drop GL_TEXTURE_1D ;
-M: texture-2d texture-gl-target drop GL_TEXTURE_2D ;
-M: texture-rectangle texture-gl-target drop GL_TEXTURE_RECTANGLE ;
-M: texture-3d texture-gl-target drop GL_TEXTURE_3D ;
-M: texture-cube-map texture-gl-target drop GL_TEXTURE_CUBE_MAP ;
-M: texture-1d-array texture-gl-target drop GL_TEXTURE_1D_ARRAY ;
-M: texture-2d-array texture-gl-target drop GL_TEXTURE_2D_ARRAY ;
-
-M: texture-1d texture-data-gl-target drop GL_TEXTURE_1D ;
-M: texture-2d texture-data-gl-target drop GL_TEXTURE_2D ;
-M: texture-rectangle texture-data-gl-target drop GL_TEXTURE_RECTANGLE ;
-M: texture-3d texture-data-gl-target drop GL_TEXTURE_3D ;
-M: texture-1d-array texture-data-gl-target drop GL_TEXTURE_1D_ARRAY ;
-M: texture-2d-array texture-data-gl-target drop GL_TEXTURE_2D_ARRAY ;
+M: texture-1d texture-gl-target drop GL_TEXTURE_1D ; inline
+M: texture-2d texture-gl-target drop GL_TEXTURE_2D ; inline
+M: texture-rectangle texture-gl-target drop GL_TEXTURE_RECTANGLE ; inline
+M: texture-3d texture-gl-target drop GL_TEXTURE_3D ; inline
+M: texture-cube-map texture-gl-target drop GL_TEXTURE_CUBE_MAP ; inline
+M: texture-1d-array texture-gl-target drop GL_TEXTURE_1D_ARRAY ; inline
+M: texture-2d-array texture-gl-target drop GL_TEXTURE_2D_ARRAY ; inline
+
+M: texture-1d texture-data-gl-target drop GL_TEXTURE_1D ; inline
+M: texture-2d texture-data-gl-target drop GL_TEXTURE_2D ; inline
+M: texture-rectangle texture-data-gl-target drop GL_TEXTURE_RECTANGLE ; inline
+M: texture-3d texture-data-gl-target drop GL_TEXTURE_3D ; inline
+M: texture-1d-array texture-data-gl-target drop GL_TEXTURE_1D_ARRAY ; inline
+M: texture-2d-array texture-data-gl-target drop GL_TEXTURE_2D_ARRAY ; inline
M: cube-map-face texture-data-gl-target
axis>> {
{ -X [ GL_TEXTURE_CUBE_MAP_NEGATIVE_X ] }
{ +X [ GL_TEXTURE_CUBE_MAP_POSITIVE_X ] }
{ +Y [ GL_TEXTURE_CUBE_MAP_POSITIVE_Y ] }
{ +Z [ GL_TEXTURE_CUBE_MAP_POSITIVE_Z ] }
- } case ;
+ } case ; inline
: texture-gl-internal-format ( texture -- internal-format )
[ component-order>> ] [ component-type>> ] bi image-internal-format ; inline
[ ptr>> ] bi
] [
[ component-order>> ] [ component-type>> ] bi image-data-format f
- ] if* ;
+ ] if* ; inline
:: bind-tdt ( tdt -- texture )
tdt texture-object :> texture
texture [ texture-gl-target ] [ handle>> ] bi glBindTexture
- texture ;
+ texture ; inline
: get-texture-float ( target level enum -- value )
- 0 <float> [ glGetTexLevelParameterfv ] keep *float ;
+ 0 <float> [ glGetTexLevelParameterfv ] keep *float ; inline
: get-texture-int ( target level enum -- value )
- 0 <int> [ glGetTexLevelParameteriv ] keep *int ;
+ 0 <int> [ glGetTexLevelParameteriv ] keep *int ; inline
: ?product ( x -- y )
- dup number? [ product ] unless ;
+ dup number? [ product ] unless ; inline
PRIVATE>
3array ;
: texture-data-size ( tdt level -- size )
- [ texture-dim ?product ] [ drop texture-object bytes-per-pixel ] 2bi * ;
+ [ texture-dim ?product ] [ drop texture-object bytes-per-pixel ] 2bi * ; inline
-:: read-texture-to ( tdt level gpu-data-ptr -- )
+TYPED:: read-texture-to ( tdt: texture-data-target level: integer gpu-data-ptr -- )
tdt bind-tdt :> texture
tdt texture-data-gl-target level
texture [ component-order>> ] [ component-type>> ] bi image-data-format
gpu-data-ptr pixel-pack-buffer [ glGetTexImage ] with-gpu-data-ptr ;
-: read-texture ( tdt level -- byte-array )
+TYPED: read-texture ( tdt: texture-data-target level: integer -- byte-array: byte-array )
2dup texture-data-size <byte-array>
[ read-texture-to ] keep ;
: allocate-texture-image ( tdt level image -- )
- image>texture-data allocate-texture ;
+ image>texture-data allocate-texture ; inline
: update-texture-image ( tdt level loc image -- )
- image>texture-data update-texture ;
+ image>texture-data update-texture ; inline
: read-texture-image ( tdt level -- image )
[ texture-dim ]
[ drop texture-object [ component-order>> ] [ component-type>> ] bi f ]
[ read-texture ] 2tri
- image boa ;
+ image boa ; inline
<PRIVATE
: bind-texture ( texture -- gl-target )
- [ texture-gl-target dup ] [ handle>> ] bi glBindTexture ;
+ [ texture-gl-target dup ] [ handle>> ] bi glBindTexture ; inline
PRIVATE>
: generate-mipmaps ( texture -- )
- bind-texture glGenerateMipmap ;
+ bind-texture glGenerateMipmap ; inline
-: set-texture-parameters ( texture parameters -- )
+TYPED: set-texture-parameters ( texture: texture parameters: texture-parameters -- )
[ bind-texture ] dip {
[ wrap>> set-texture-gl-wrap ]
[
PRIVATE>
: <texture-1d> ( component-order component-type parameters -- texture )
- texture-1d <texture> ;
+ texture-1d <texture> ; inline
: <texture-2d> ( component-order component-type parameters -- texture )
- texture-2d <texture> ;
+ texture-2d <texture> ; inline
: <texture-3d> ( component-order component-type parameters -- texture )
- texture-3d <texture> ;
+ texture-3d <texture> ; inline
: <texture-cube-map> ( component-order component-type parameters -- texture )
- texture-cube-map <texture> ;
+ texture-cube-map <texture> ; inline
: <texture-rectangle> ( component-order component-type parameters -- texture )
- texture-rectangle <texture> ;
+ texture-rectangle <texture> ; inline
: <texture-1d-array> ( component-order component-type parameters -- texture )
- texture-1d-array <texture> ;
+ texture-1d-array <texture> ; inline
: <texture-2d-array> ( component-order component-type parameters -- texture )
- texture-2d-array <texture> ;
+ texture-2d-array <texture> ; inline
: <window-vertex-buffer> ( -- buffer )
window-vertexes
static-upload draw-usage vertex-buffer
- byte-array>buffer ;
+ byte-array>buffer ; inline
: <window-vertex-array> ( program-instance -- vertex-array )
- [ <window-vertex-buffer> ] dip window-vertex buffer>vertex-array ;
+ [ <window-vertex-buffer> ] dip window-vertex buffer>vertex-array ; inline
CONSTANT: VELOCITY-MODIFIER-FAST float-4{ 2.0 1.0 2.0 0.0 }
CONSTANT: BOUNCE float-4{ 1.0 -0.2 1.0 1.0 }
CONSTANT: PLAYER-HEIGHT 1/256.
-CONSTANT: GRAVITY float-4{ 0.0 -1/4096. 0.0 0.0 }
-CONSTANT: JUMP 1/1024.
-CONSTANT: MOUSE-SCALE 1/10.
-CONSTANT: MOVEMENT-SPEED 1/16384.
-CONSTANT: FRICTION float-4{ 0.95 0.99 0.95 1.0 }
+CONSTANT: GRAVITY float-4{ 0.0 -1/8192. 0.0 0.0 }
+CONSTANT: JUMP 1/2048.
+CONSTANT: MOUSE-SCALE 1/20.
+CONSTANT: MOVEMENT-SPEED 1/32768.
+CONSTANT: FRICTION float-4{ 0.97 0.995 0.97 1.0 }
CONSTANT: COMPONENT-SCALE float-4{ 0.5 0.01 0.0005 0.0 }
-CONSTANT: SKY-PERIOD 1200
-CONSTANT: SKY-SPEED 0.0005
+CONSTANT: SKY-PERIOD 2400
+CONSTANT: SKY-SPEED 0.00025
CONSTANT: terrain-vertex-size { 512 512 }
VELOCITY-MODIFIER-NORMAL >>velocity-modifier ;
M: terrain-world tick-length
- drop 1000000 30 /i ;
+ drop 1000000 60 /i ;
: frustum ( dim -- -x x -y y near far )
dup first2 min v/n