Merge branch 'master' of git://factorcode.org/git/factor
Daniel Ehrenberg
commit
bed61c977c
|
|
@ -34,6 +34,10 @@ HELP: stack-size
|
|||
{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." }
|
||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||
|
||||
HELP: byte-length
|
||||
{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } }
|
||||
{ $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ;
|
||||
|
||||
HELP: c-getter
|
||||
{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( c-ptr n -- obj )" } } }
|
||||
{ $description "Outputs a quotation which reads values of this C type from a C structure." }
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: byte-arrays arrays generator.registers assocs
|
||||
kernel kernel.private libc math namespaces parser sequences
|
||||
strings words assocs splitting math.parser cpu.architecture
|
||||
alien alien.accessors quotations system compiler.units ;
|
||||
USING: bit-arrays byte-arrays float-arrays arrays
|
||||
generator.registers assocs kernel kernel.private libc math
|
||||
namespaces parser sequences strings words assocs splitting
|
||||
math.parser cpu.architecture alien alien.accessors quotations
|
||||
system compiler.units ;
|
||||
IN: alien.c-types
|
||||
|
||||
TUPLE: c-type
|
||||
|
|
@ -107,6 +108,14 @@ M: string stack-size c-type stack-size ;
|
|||
|
||||
M: c-type stack-size c-type-size ;
|
||||
|
||||
GENERIC: byte-length ( seq -- n ) flushable
|
||||
|
||||
M: bit-array byte-length length 7 + -3 shift ;
|
||||
|
||||
M: byte-array byte-length length ;
|
||||
|
||||
M: float-array byte-length length "double" heap-size * ;
|
||||
|
||||
: c-getter ( name -- quot )
|
||||
c-type c-type-getter [
|
||||
[ "Cannot read struct fields with type" throw ]
|
||||
|
|
@ -205,6 +214,9 @@ M: long-long-type box-return ( type -- )
|
|||
over [ <c-object> tuck 0 ] over c-setter append swap
|
||||
>r >r constructor-word r> r> add* define-inline ;
|
||||
|
||||
: c-bool> ( int -- ? )
|
||||
zero? not ;
|
||||
|
||||
: >c-array ( seq type word -- )
|
||||
>r >r dup length dup r> <c-array> dup -roll r>
|
||||
[ execute ] 2curry 2each ; inline
|
||||
|
|
|
|||
|
|
@ -203,7 +203,14 @@ M: f '
|
|||
|
||||
! Words
|
||||
|
||||
DEFER: emit-word
|
||||
|
||||
: emit-generic ( generic -- )
|
||||
dup "default-method" word-prop method-word emit-word
|
||||
"methods" word-prop [ nip method-word emit-word ] assoc-each ;
|
||||
|
||||
: emit-word ( word -- )
|
||||
dup generic? [ dup emit-generic ] when
|
||||
[
|
||||
dup hashcode ' ,
|
||||
dup word-name ' ,
|
||||
|
|
@ -224,7 +231,7 @@ M: f '
|
|||
[ % dup word-vocabulary % " " % word-name % ] "" make throw ;
|
||||
|
||||
: transfer-word ( word -- word )
|
||||
dup target-word [ ] [ word-name no-word ] ?if ;
|
||||
dup target-word swap or ;
|
||||
|
||||
: fixup-word ( word -- offset )
|
||||
transfer-word dup objects get at
|
||||
|
|
@ -248,7 +255,7 @@ M: wrapper '
|
|||
emit-seq ;
|
||||
|
||||
: pack-string ( string -- newstr )
|
||||
dup length 1+ bootstrap-cell align 0 pad-right ;
|
||||
dup length bootstrap-cell align 0 pad-right ;
|
||||
|
||||
: emit-string ( string -- ptr )
|
||||
string type-number object tag-number [
|
||||
|
|
@ -285,17 +292,20 @@ M: float-array ' float-array emit-dummy-array ;
|
|||
] emit-object ;
|
||||
|
||||
: emit-tuple ( obj -- pointer )
|
||||
objects get [
|
||||
[
|
||||
[ tuple>array unclip transfer-word , % ] { } make
|
||||
tuple type-number dup emit-array
|
||||
] cache ; inline
|
||||
]
|
||||
! Hack
|
||||
over class word-name "tombstone" =
|
||||
[ objects get swap cache ] [ call ] if ;
|
||||
|
||||
M: tuple ' emit-tuple ;
|
||||
|
||||
M: tombstone '
|
||||
delegate
|
||||
"((tombstone))" "((empty))" ? "hashtables.private" lookup
|
||||
word-def first emit-tuple ;
|
||||
word-def first objects get [ emit-tuple ] cache ;
|
||||
|
||||
M: array '
|
||||
array type-number object tag-number emit-array ;
|
||||
|
|
@ -313,41 +323,6 @@ M: quotation '
|
|||
] emit-object
|
||||
] cache ;
|
||||
|
||||
! Vectors and sbufs
|
||||
|
||||
M: vector '
|
||||
dup length swap underlying '
|
||||
tuple type-number tuple tag-number [
|
||||
4 emit-fixnum
|
||||
vector ' emit
|
||||
f ' emit
|
||||
emit ! array ptr
|
||||
emit-fixnum ! length
|
||||
] emit-object ;
|
||||
|
||||
M: sbuf '
|
||||
dup length swap underlying '
|
||||
tuple type-number tuple tag-number [
|
||||
4 emit-fixnum
|
||||
sbuf ' emit
|
||||
f ' emit
|
||||
emit ! array ptr
|
||||
emit-fixnum ! length
|
||||
] emit-object ;
|
||||
|
||||
! Hashes
|
||||
|
||||
M: hashtable '
|
||||
[ hash-array ' ] keep
|
||||
tuple type-number tuple tag-number [
|
||||
5 emit-fixnum
|
||||
hashtable ' emit
|
||||
f ' emit
|
||||
dup hash-count emit-fixnum
|
||||
hash-deleted emit-fixnum
|
||||
emit ! array ptr
|
||||
] emit-object ;
|
||||
|
||||
! Curries
|
||||
|
||||
M: curry '
|
||||
|
|
|
|||
|
|
@ -118,11 +118,11 @@ H{ } clone update-map set
|
|||
H{ } clone typemap set
|
||||
num-types get f <array> builtins set
|
||||
|
||||
! These symbols are needed by the code that executes below
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
{ "null" "kernel" }
|
||||
} [ create drop ] assoc-each
|
||||
! Forward definitions
|
||||
"object" "kernel" create t "class" set-word-prop
|
||||
"object" "kernel" create union-class "metaclass" set-word-prop
|
||||
|
||||
"null" "kernel" create drop
|
||||
|
||||
"fixnum" "math" create "fixnum?" "math" create { } define-builtin
|
||||
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
|
||||
|
|
|
|||
|
|
@ -32,6 +32,7 @@ vocabs.loader system ;
|
|||
|
||||
"io.streams.c" require
|
||||
"vocabs.loader" require
|
||||
|
||||
"syntax" require
|
||||
"bootstrap.layouts" require
|
||||
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ IN: bootstrap.stage2
|
|||
vm file-name windows? [ "." split1 drop ] when
|
||||
".image" append "output-image" set-global
|
||||
|
||||
"math tools help compiler ui ui.tools io" "include" set-global
|
||||
"math help compiler tools ui ui.tools io" "include" set-global
|
||||
"" "exclude" set-global
|
||||
|
||||
parse-command-line
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: classes
|
||||
USING: arrays definitions assocs kernel
|
||||
|
|
|
|||
|
|
@ -1,19 +1,34 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: words sequences kernel assocs combinators classes
|
||||
generic.standard namespaces arrays ;
|
||||
generic.standard namespaces arrays math quotations ;
|
||||
IN: classes.union
|
||||
|
||||
PREDICATE: class union-class
|
||||
"metaclass" word-prop union-class eq? ;
|
||||
|
||||
! Union classes for dispatch on multiple classes.
|
||||
: small-union-predicate-quot ( members -- quot )
|
||||
dup empty? [
|
||||
drop [ drop f ]
|
||||
] [
|
||||
unclip first "predicate" word-prop swap
|
||||
[ >r "predicate" word-prop [ dup ] swap append r> ]
|
||||
assoc-map alist>quot
|
||||
] if ;
|
||||
|
||||
: big-union-predicate-quot ( members -- quot )
|
||||
[ small-union-predicate-quot ] [ dup ]
|
||||
class-hash-dispatch-quot ;
|
||||
|
||||
: union-predicate-quot ( members -- quot )
|
||||
0 (dispatch#) [
|
||||
[ [ drop t ] ] { } map>assoc
|
||||
object bootstrap-word [ drop f ] 2array add*
|
||||
single-combination
|
||||
] with-variable ;
|
||||
[ [ drop t ] ] { } map>assoc
|
||||
dup length 4 <= [
|
||||
small-union-predicate-quot
|
||||
] [
|
||||
flatten-methods
|
||||
big-union-predicate-quot
|
||||
] if ;
|
||||
|
||||
: define-union-predicate ( class -- )
|
||||
dup predicate-word
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ IN: compiler
|
|||
>r dupd save-effect r>
|
||||
f pick compiler-error
|
||||
over compiled-unxref
|
||||
over word-vocabulary [ compiled-xref ] [ 2drop ] if ;
|
||||
over crossref? [ compiled-xref ] [ 2drop ] if ;
|
||||
|
||||
: compile-succeeded ( word -- effect dependencies )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -132,8 +132,8 @@ FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
|
|||
[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
|
||||
|
||||
FUNCTION: void ffi_test_20 double x1, double x2, double x3,
|
||||
double y1, double y2, double y3,
|
||||
double z1, double z2, double z3 ;
|
||||
double y1, double y2, double y3,
|
||||
double z1, double z2, double z3 ;
|
||||
|
||||
[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
|
||||
|
||||
|
|
@ -270,6 +270,16 @@ FUNCTION: double ffi_test_35 test-struct-11 x int y ;
|
|||
3 ffi_test_35
|
||||
] unit-test
|
||||
|
||||
C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
|
||||
|
||||
: make-struct-12
|
||||
"test-struct-12" <c-object>
|
||||
[ set-test-struct-12-x ] keep ;
|
||||
|
||||
FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
|
||||
|
||||
[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
|
||||
|
||||
! Test callbacks
|
||||
|
||||
: callback-1 "void" { } "cdecl" [ ] alien-callback ;
|
||||
|
|
|
|||
|
|
@ -261,6 +261,10 @@ windows? [
|
|||
cell "ulonglong" c-type set-c-type-align
|
||||
] unless
|
||||
|
||||
macosx? [
|
||||
cell "double" c-type set-c-type-align
|
||||
] when
|
||||
|
||||
T{ x86-backend f 4 } compiler-backend set-global
|
||||
|
||||
: sse2? "Intrinsic" throw ;
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ SYMBOL: generic-1
|
|||
[
|
||||
generic-1 T{ combination-1 } define-generic
|
||||
|
||||
[ ] <method> object \ generic-1 define-method
|
||||
[ ] object \ generic-1 define-method
|
||||
] with-compilation-unit
|
||||
|
||||
[ ] [
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math namespaces sequences strings words assocs
|
||||
combinators ;
|
||||
|
|
@ -41,13 +41,13 @@ M: integer (stack-picture) drop "object" ;
|
|||
")" %
|
||||
] "" make ;
|
||||
|
||||
: stack-effect ( word -- effect/f )
|
||||
dup symbol? [
|
||||
drop 0 1 <effect>
|
||||
] [
|
||||
{ "declared-effect" "inferred-effect" }
|
||||
swap word-props [ at ] curry map [ ] find nip
|
||||
] if ;
|
||||
GENERIC: stack-effect ( word -- effect/f )
|
||||
|
||||
M: symbol stack-effect drop 0 1 <effect> ;
|
||||
|
||||
M: word stack-effect
|
||||
{ "declared-effect" "inferred-effect" }
|
||||
swap word-props [ at ] curry map [ ] find nip ;
|
||||
|
||||
M: effect clone
|
||||
[ effect-in clone ] keep effect-out clone <effect> ;
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ HELP: <float-array> ( n initial -- float-array )
|
|||
|
||||
HELP: >float-array
|
||||
{ $values { "seq" "a sequence" } { "float-array" float-array } }
|
||||
{ $description "Outputs a freshly-allocated float array whose elements have the same boolean values as a given sequence." }
|
||||
{ $description "Outputs a freshly-allocated float array whose elements have the same floating-point values as a given sequence." }
|
||||
{ $errors "Throws an error if the sequence contains elements other than real numbers." } ;
|
||||
|
||||
HELP: 1float-array
|
||||
|
|
|
|||
|
|
@ -154,9 +154,17 @@ M: #if generate-node
|
|||
] generate-1
|
||||
] keep ;
|
||||
|
||||
: tail-dispatch? ( node -- ? )
|
||||
#! Is the dispatch a jump to a tail call to a word?
|
||||
dup #call? swap node-successor #return? and ;
|
||||
|
||||
: dispatch-branches ( node -- )
|
||||
node-children [
|
||||
compiling-word get dispatch-branch %dispatch-label
|
||||
dup tail-dispatch? [
|
||||
node-param
|
||||
] [
|
||||
compiling-word get dispatch-branch
|
||||
] if %dispatch-label
|
||||
] each ;
|
||||
|
||||
M: #dispatch generate-node
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: help.markup help.syntax generic.math generic.standard
|
||||
words classes definitions kernel alien combinators sequences
|
||||
math ;
|
||||
math quotations ;
|
||||
IN: generic
|
||||
|
||||
ARTICLE: "method-order" "Method precedence"
|
||||
|
|
@ -107,10 +107,6 @@ HELP: make-generic
|
|||
{ $description "Regenerates the definition of a generic word by applying the method combination to the set of defined methods." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: init-methods
|
||||
{ $values { "word" word } }
|
||||
{ $description "Prepare to define a generic word." } ;
|
||||
|
||||
HELP: define-generic
|
||||
{ $values { "word" word } { "combination" "a method combination" } }
|
||||
{ $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." }
|
||||
|
|
@ -125,16 +121,12 @@ HELP: method
|
|||
{ $description "Looks up a method definition." }
|
||||
{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
|
||||
|
||||
{ method method-def method-loc define-method POSTPONE: M: } related-words
|
||||
{ method define-method POSTPONE: M: } related-words
|
||||
|
||||
HELP: <method>
|
||||
{ $values { "def" "a quotation" } { "method" "a new method definition" } }
|
||||
{ $description "Creates a new "{ $link method } " instance." } ;
|
||||
|
||||
HELP: sort-methods
|
||||
{ $values { "assoc" "an assoc mapping classes to methods" } { "newassoc" "an association list mapping classes to quotations" } }
|
||||
{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
|
||||
|
||||
HELP: methods
|
||||
{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
|
||||
{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
|
||||
|
|
@ -154,7 +146,7 @@ HELP: with-methods
|
|||
$low-level-note ;
|
||||
|
||||
HELP: define-method
|
||||
{ $values { "method" "an instance of " { $link method } } { "class" class } { "generic" generic } }
|
||||
{ $values { "method" quotation } { "class" class } { "generic" generic } }
|
||||
{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
|
||||
|
||||
HELP: implementors
|
||||
|
|
|
|||
|
|
@ -176,6 +176,9 @@ M: f tag-and-f 4 ;
|
|||
! define-class hashing issue
|
||||
TUPLE: debug-combination ;
|
||||
|
||||
M: debug-combination make-default-method
|
||||
2drop [ "Oops" throw ] when ;
|
||||
|
||||
M: debug-combination perform-combination
|
||||
drop
|
||||
order [ dup class-hashes ] { } map>assoc sort-keys
|
||||
|
|
|
|||
|
|
@ -1,16 +1,11 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: words kernel sequences namespaces assocs hashtables
|
||||
definitions kernel.private classes classes.private
|
||||
quotations arrays vocabs ;
|
||||
quotations arrays vocabs effects ;
|
||||
IN: generic
|
||||
|
||||
PREDICATE: word generic "combination" word-prop >boolean ;
|
||||
|
||||
M: generic definer drop f f ;
|
||||
|
||||
M: generic definition drop f ;
|
||||
|
||||
! Method combination protocol
|
||||
GENERIC: perform-combination ( word combination -- quot )
|
||||
|
||||
M: object perform-combination
|
||||
|
|
@ -22,27 +17,22 @@ M: object perform-combination
|
|||
#! the method will throw an error. We don't want that.
|
||||
nip [ "Invalid method combination" throw ] curry [ ] like ;
|
||||
|
||||
GENERIC: method-prologue ( class combination -- quot )
|
||||
|
||||
M: object method-prologue 2drop [ ] ;
|
||||
|
||||
GENERIC: make-default-method ( generic combination -- method )
|
||||
|
||||
PREDICATE: word generic "combination" word-prop >boolean ;
|
||||
|
||||
M: generic definer drop f f ;
|
||||
|
||||
M: generic definition drop f ;
|
||||
|
||||
: make-generic ( word -- )
|
||||
dup dup "combination" word-prop perform-combination define ;
|
||||
|
||||
: init-methods ( word -- )
|
||||
dup "methods" word-prop
|
||||
H{ } assoc-like
|
||||
"methods" set-word-prop ;
|
||||
|
||||
: define-generic ( word combination -- )
|
||||
dupd "combination" set-word-prop
|
||||
dup init-methods make-generic ;
|
||||
|
||||
TUPLE: method loc def ;
|
||||
|
||||
: <method> ( def -- method )
|
||||
{ set-method-def } \ method construct ;
|
||||
|
||||
M: f method-def ;
|
||||
M: f method-loc ;
|
||||
M: quotation method-def ;
|
||||
M: quotation method-loc drop f ;
|
||||
TUPLE: method word def specializer generic loc ;
|
||||
|
||||
: method ( class generic -- method/f )
|
||||
"methods" word-prop at ;
|
||||
|
|
@ -53,12 +43,10 @@ PREDICATE: pair method-spec
|
|||
: order ( generic -- seq )
|
||||
"methods" word-prop keys sort-classes ;
|
||||
|
||||
: sort-methods ( assoc -- newassoc )
|
||||
[ keys sort-classes ] keep
|
||||
[ dupd at method-def 2array ] curry map ;
|
||||
|
||||
: methods ( word -- assoc )
|
||||
"methods" word-prop sort-methods ;
|
||||
"methods" word-prop
|
||||
[ keys sort-classes ] keep
|
||||
[ dupd at method-word ] curry { } map>assoc ;
|
||||
|
||||
TUPLE: check-method class generic ;
|
||||
|
||||
|
|
@ -71,19 +59,46 @@ TUPLE: check-method class generic ;
|
|||
swap [ "methods" word-prop swap call ] keep make-generic ;
|
||||
inline
|
||||
|
||||
: define-method ( method class generic -- )
|
||||
>r bootstrap-word r> check-method
|
||||
: method-word-name ( class word -- string )
|
||||
word-name "/" rot word-name 3append ;
|
||||
|
||||
: make-method-def ( quot word combination -- quot )
|
||||
"combination" word-prop method-prologue swap append ;
|
||||
|
||||
PREDICATE: word method-body "method" word-prop >boolean ;
|
||||
|
||||
M: method-body stack-effect
|
||||
"method" word-prop method-generic stack-effect ;
|
||||
|
||||
: <method-word> ( quot class generic -- word )
|
||||
[ make-method-def ] 2keep
|
||||
method-word-name f <word>
|
||||
dup rot define ;
|
||||
|
||||
: <method> ( quot class generic -- method )
|
||||
check-method
|
||||
[ <method-word> ] 3keep f \ method construct-boa
|
||||
dup method-word over "method" set-word-prop ;
|
||||
|
||||
: define-method ( quot class generic -- )
|
||||
>r bootstrap-word r>
|
||||
[ <method> ] 2keep
|
||||
[ set-at ] with-methods ;
|
||||
|
||||
: define-default-method ( generic combination -- )
|
||||
dupd make-default-method object bootstrap-word pick <method>
|
||||
"default-method" set-word-prop ;
|
||||
|
||||
! Definition protocol
|
||||
M: method-spec where
|
||||
dup first2 method method-loc [ ] [ second where ] ?if ;
|
||||
dup first2 method [ method-loc ] [ second where ] ?if ;
|
||||
|
||||
M: method-spec set-where first2 method set-method-loc ;
|
||||
|
||||
M: method-spec definer drop \ M: \ ; ;
|
||||
|
||||
M: method-spec definition first2 method method-def ;
|
||||
M: method-spec definition
|
||||
first2 method dup [ method-def ] when ;
|
||||
|
||||
: forget-method ( class generic -- )
|
||||
check-method [ delete-at ] with-methods ;
|
||||
|
|
@ -109,3 +124,23 @@ M: class forget* ( class -- )
|
|||
|
||||
M: assoc update-methods ( assoc -- )
|
||||
implementors* [ make-generic ] each ;
|
||||
|
||||
: define-generic ( word combination -- )
|
||||
over "combination" word-prop over = [
|
||||
2drop
|
||||
] [
|
||||
2dup "combination" set-word-prop
|
||||
over H{ } clone "methods" set-word-prop
|
||||
dupd define-default-method
|
||||
make-generic
|
||||
] if ;
|
||||
|
||||
: subwords ( generic -- seq )
|
||||
dup "methods" word-prop values
|
||||
swap "default-method" word-prop add
|
||||
[ method-word ] map ;
|
||||
|
||||
: xref-generics ( -- )
|
||||
all-words
|
||||
[ generic? ] subset
|
||||
[ subwords [ xref ] each ] each ;
|
||||
|
|
|
|||
|
|
@ -38,9 +38,13 @@ TUPLE: no-math-method left right generic ;
|
|||
: no-math-method ( left right generic -- * )
|
||||
\ no-math-method construct-boa throw ;
|
||||
|
||||
: default-math-method ( generic -- quot )
|
||||
[ no-math-method ] curry [ ] like ;
|
||||
|
||||
: applicable-method ( generic class -- quot )
|
||||
over method method-def
|
||||
[ ] [ [ no-math-method ] curry [ ] like ] ?if ;
|
||||
over method
|
||||
[ method-word word-def ]
|
||||
[ default-math-method ] ?if ;
|
||||
|
||||
: object-method ( generic -- quot )
|
||||
object bootstrap-word applicable-method ;
|
||||
|
|
@ -66,6 +70,9 @@ TUPLE: no-math-method left right generic ;
|
|||
|
||||
TUPLE: math-combination ;
|
||||
|
||||
M: math-combination make-default-method
|
||||
drop default-math-method ;
|
||||
|
||||
M: math-combination perform-combination
|
||||
drop
|
||||
\ over [
|
||||
|
|
|
|||
|
|
@ -8,6 +8,10 @@ IN: generic.standard
|
|||
|
||||
TUPLE: standard-combination # ;
|
||||
|
||||
M: standard-combination method-prologue
|
||||
standard-combination-# object
|
||||
<array> swap add* [ declare ] curry ;
|
||||
|
||||
C: <standard-combination> standard-combination
|
||||
|
||||
SYMBOL: (dispatch#)
|
||||
|
|
@ -31,10 +35,10 @@ TUPLE: no-method object generic ;
|
|||
: no-method ( object generic -- * )
|
||||
\ no-method construct-boa throw ;
|
||||
|
||||
: error-method ( word -- method )
|
||||
: error-method ( word -- quot )
|
||||
picker swap [ no-method ] curry append ;
|
||||
|
||||
: empty-method ( word -- method )
|
||||
: empty-method ( word -- quot )
|
||||
[
|
||||
picker % [ delegate dup ] %
|
||||
unpicker over add ,
|
||||
|
|
@ -65,13 +69,15 @@ TUPLE: no-method object generic ;
|
|||
] if ;
|
||||
|
||||
: default-method ( word -- pair )
|
||||
empty-method object bootstrap-word swap 2array ;
|
||||
"default-method" word-prop method-word
|
||||
object bootstrap-word swap 2array ;
|
||||
|
||||
: method-alist>quot ( alist base-class -- quot )
|
||||
bootstrap-word swap simplify-alist
|
||||
class-predicates alist>quot ;
|
||||
|
||||
: small-generic ( methods -- def )
|
||||
[ 1quotation ] assoc-map
|
||||
object method-alist>quot ;
|
||||
|
||||
: hash-methods ( methods -- buckets )
|
||||
|
|
@ -83,9 +89,12 @@ TUPLE: no-method object generic ;
|
|||
] if
|
||||
] distribute-buckets ;
|
||||
|
||||
: class-hash-dispatch-quot ( methods quot picker -- quot )
|
||||
>r >r hash-methods r> map
|
||||
hash-dispatch-quot r> [ class-hash ] rot 3append ;
|
||||
|
||||
: big-generic ( methods -- quot )
|
||||
hash-methods [ small-generic ] map
|
||||
hash-dispatch-quot picker [ class-hash ] rot 3append ;
|
||||
[ small-generic ] picker class-hash-dispatch-quot ;
|
||||
|
||||
: vtable-class ( n -- class )
|
||||
type>class [ hi-tag bootstrap-word ] unless* ;
|
||||
|
|
@ -100,7 +109,8 @@ TUPLE: no-method object generic ;
|
|||
|
||||
: build-type-vtable ( alist-seq -- alist-seq )
|
||||
dup length [
|
||||
vtable-class swap simplify-alist
|
||||
vtable-class
|
||||
swap [ word-def ] assoc-map simplify-alist
|
||||
class-predicates alist>quot
|
||||
] 2map ;
|
||||
|
||||
|
|
@ -137,30 +147,35 @@ TUPLE: no-method object generic ;
|
|||
: standard-methods ( word -- alist )
|
||||
dup methods swap default-method add* ;
|
||||
|
||||
M: standard-combination make-default-method
|
||||
standard-combination-# (dispatch#)
|
||||
[ empty-method ] with-variable ;
|
||||
|
||||
M: standard-combination perform-combination
|
||||
standard-combination-# (dispatch#) [
|
||||
[ standard-methods ] keep "inline" word-prop
|
||||
[ small-generic ] [ single-combination ] if
|
||||
] with-variable ;
|
||||
|
||||
: default-hook-method ( word -- pair )
|
||||
error-method object bootstrap-word swap 2array ;
|
||||
|
||||
: hook-methods ( word -- methods )
|
||||
dup methods [ [ drop ] swap append ] assoc-map
|
||||
swap default-hook-method add* ;
|
||||
|
||||
TUPLE: hook-combination var ;
|
||||
|
||||
C: <hook-combination> hook-combination
|
||||
|
||||
M: hook-combination perform-combination
|
||||
M: hook-combination method-prologue
|
||||
2drop [ drop ] ;
|
||||
|
||||
: with-hook ( combination quot -- quot' )
|
||||
0 (dispatch#) [
|
||||
[
|
||||
hook-combination-var [ get ] curry %
|
||||
hook-methods single-combination %
|
||||
] [ ] make
|
||||
] with-variable ;
|
||||
swap slip
|
||||
hook-combination-var [ get ] curry
|
||||
swap append
|
||||
] with-variable ; inline
|
||||
|
||||
M: hook-combination make-default-method
|
||||
[ error-method ] with-hook ;
|
||||
|
||||
M: hook-combination perform-combination
|
||||
[ standard-methods single-combination ] with-hook ;
|
||||
|
||||
: define-simple-generic ( word -- )
|
||||
T{ standard-combination f 0 } define-generic ;
|
||||
|
|
|
|||
|
|
@ -9,9 +9,13 @@ IN: inference.backend
|
|||
: recursive-label ( word -- label/f )
|
||||
recursive-state get at ;
|
||||
|
||||
: inline? ( word -- ? )
|
||||
dup "method" word-prop
|
||||
[ method-generic inline? ] [ "inline" word-prop ] ?if ;
|
||||
|
||||
: local-recursive-state ( -- assoc )
|
||||
recursive-state get dup keys
|
||||
[ dup word? [ "inline" word-prop ] when not ] find drop
|
||||
[ dup word? [ inline? ] when not ] find drop
|
||||
[ head-slice ] when* ;
|
||||
|
||||
: inline-recursive-label ( word -- label/f )
|
||||
|
|
@ -157,7 +161,7 @@ TUPLE: too-many-r> ;
|
|||
meta-d get push-all ;
|
||||
|
||||
: if-inline ( word true false -- )
|
||||
>r >r dup "inline" word-prop r> r> if ; inline
|
||||
>r >r dup inline? r> r> if ; inline
|
||||
|
||||
: consume/produce ( effect node -- )
|
||||
over effect-in over consume-values
|
||||
|
|
@ -331,7 +335,7 @@ TUPLE: unbalanced-branches-error quots in out ;
|
|||
#merge node, ; inline
|
||||
|
||||
: make-call-node ( word effect -- )
|
||||
swap dup "inline" word-prop
|
||||
swap dup inline?
|
||||
over dup recursive-label eq? not and [
|
||||
meta-d get clone -rot
|
||||
recursive-label #call-label [ consume/produce ] keep
|
||||
|
|
|
|||
|
|
@ -54,6 +54,8 @@ M: pair (bitfield-quot) ( spec -- quot )
|
|||
|
||||
\ bitfield [ bitfield-quot ] 1 define-transform
|
||||
|
||||
\ flags [ flags [ ] curry ] 1 define-transform
|
||||
|
||||
! Tuple operations
|
||||
: [get-slots] ( slots -- quot )
|
||||
[ [ 1quotation , \ keep , ] each \ drop , ] [ ] make ;
|
||||
|
|
|
|||
|
|
@ -2,16 +2,16 @@ USING: help.markup help.syntax math ;
|
|||
IN: io.crc32
|
||||
|
||||
HELP: crc32
|
||||
{ $values { "seq" "a sequence" } { "n" integer } }
|
||||
{ $values { "seq" "a sequence of bytes" } { "n" integer } }
|
||||
{ $description "Computes the CRC32 checksum of a sequence of bytes." } ;
|
||||
|
||||
HELP: file-crc32
|
||||
{ $values { "path" "a pathname string" } { "n" integer } }
|
||||
{ $description "Computes the CRC32 checksum of a file's contents." } ;
|
||||
HELP: lines-crc32
|
||||
{ $values { "lines" "a sequence of strings" } { "n" integer } }
|
||||
{ $description "Computes the CRC32 checksum of a sequence of lines of bytes." } ;
|
||||
|
||||
ARTICLE: "io.crc32" "CRC32 checksum calculation"
|
||||
"The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data."
|
||||
{ $subsection crc32 }
|
||||
{ $subsection file-crc32 } ;
|
||||
{ $subsection lines-crc32 } ;
|
||||
|
||||
ABOUT: "io.crc32"
|
||||
|
|
|
|||
|
|
@ -23,8 +23,6 @@ IN: io.crc32
|
|||
: crc32 ( seq -- n )
|
||||
>r HEX: ffffffff dup r> [ (crc32) ] each bitxor ;
|
||||
|
||||
: file-crc32 ( path -- n ) file-contents crc32 ;
|
||||
|
||||
: lines-crc32 ( seq -- n )
|
||||
HEX: ffffffff tuck [
|
||||
[ (crc32) ] each CHAR: \n (crc32)
|
||||
|
|
|
|||
|
|
@ -74,3 +74,10 @@ M: object <file-writer>
|
|||
|
||||
M: object <file-appender>
|
||||
"ab" fopen <c-writer> <plain-writer> ;
|
||||
|
||||
: show ( msg -- )
|
||||
#! A word which directly calls primitives. It is used to
|
||||
#! print stuff from contexts where the I/O system would
|
||||
#! otherwise not work (tools.deploy.shaker, the I/O
|
||||
#! multiplexer thread).
|
||||
"\r\n" append stdout-handle fwrite stdout-handle fflush ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math sequences words ;
|
||||
IN: math.bitfields
|
||||
|
|
@ -13,3 +13,6 @@ M: pair (bitfield) ( value accum pair -- newaccum )
|
|||
|
||||
: bitfield ( values... bitspec -- n )
|
||||
0 [ (bitfield) ] reduce ;
|
||||
|
||||
: flags ( values -- n )
|
||||
0 [ dup word? [ execute ] when bitor ] reduce ;
|
||||
|
|
|
|||
|
|
@ -245,11 +245,19 @@ M: #dispatch optimize-node*
|
|||
: dispatching-class ( node word -- class )
|
||||
[ dispatch# node-class# ] keep specific-method ;
|
||||
|
||||
: flat-length ( seq -- n )
|
||||
[
|
||||
dup quotation? over array? or
|
||||
[ flat-length ] [ drop 1 ] if
|
||||
] map sum ;
|
||||
|
||||
: will-inline-method ( node word -- method-spec/t quot/t )
|
||||
#! t indicates failure
|
||||
tuck dispatching-class dup [
|
||||
swap [ 2array ] 2keep
|
||||
method method-def
|
||||
method method-word
|
||||
dup word-def flat-length 5 >=
|
||||
[ 1quotation ] [ word-def ] if
|
||||
] [
|
||||
2drop t t
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -21,9 +21,9 @@ IN: temporary
|
|||
[ "hello\\backslash" unparse ]
|
||||
unit-test
|
||||
|
||||
[ "\"\\u123456\"" ]
|
||||
[ "\u123456" unparse ]
|
||||
unit-test
|
||||
! [ "\"\\u123456\"" ]
|
||||
! [ "\u123456" unparse ]
|
||||
! unit-test
|
||||
|
||||
[ "\"\\e\"" ]
|
||||
[ "\e" unparse ]
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ TUPLE: slot-spec type name offset reader writer ;
|
|||
C: <slot-spec> slot-spec
|
||||
|
||||
: define-typecheck ( class generic quot -- )
|
||||
<method> over define-simple-generic -rot define-method ;
|
||||
over define-simple-generic -rot define-method ;
|
||||
|
||||
: define-slot-word ( class slot word quot -- )
|
||||
rot >fixnum add* define-typecheck ;
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ uses definitions ;
|
|||
|
||||
: (source-modified?) ( path modified checksum -- ? )
|
||||
pick file-modified rot [ 0 or ] 2apply >
|
||||
[ swap file-crc32 number= not ] [ 2drop f ] if ;
|
||||
[ swap file-lines lines-crc32 = not ] [ 2drop f ] if ;
|
||||
|
||||
: source-modified? ( path -- ? )
|
||||
dup source-files get at [
|
||||
|
|
|
|||
|
|
@ -88,8 +88,6 @@ unit-test
|
|||
|
||||
! Make sure aux vector is not shared
|
||||
[ "\udeadbe" ] [
|
||||
"\udeadbe" clone
|
||||
CHAR: \u123456 over clone set-first
|
||||
"\udeadbe" clone
|
||||
CHAR: \u123456 over clone set-first
|
||||
] unit-test
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -126,7 +126,7 @@ IN: bootstrap.syntax
|
|||
f set-word
|
||||
location >r
|
||||
scan-word bootstrap-word scan-word
|
||||
[ parse-definition <method> -rot define-method ] 2keep
|
||||
[ parse-definition -rot define-method ] 2keep
|
||||
2array r> remember-definition
|
||||
] define-syntax
|
||||
|
||||
|
|
|
|||
|
|
@ -116,13 +116,16 @@ SYMBOL: changed-words
|
|||
[ no-compilation-unit ] unless*
|
||||
set-at ;
|
||||
|
||||
: crossref? ( word -- ? )
|
||||
dup word-vocabulary swap "method" word-prop or ;
|
||||
|
||||
: define ( word def -- )
|
||||
[ ] like
|
||||
over unxref
|
||||
over redefined
|
||||
over set-word-def
|
||||
dup changed-word
|
||||
dup word-vocabulary [ dup xref ] when drop ;
|
||||
dup crossref? [ dup xref ] when drop ;
|
||||
|
||||
: define-declared ( word def effect -- )
|
||||
pick swap "declared-effect" set-word-prop
|
||||
|
|
@ -154,7 +157,8 @@ SYMBOL: changed-words
|
|||
} reset-props ;
|
||||
|
||||
: reset-generic ( word -- )
|
||||
dup reset-word { "methods" "combination" } reset-props ;
|
||||
dup reset-word
|
||||
{ "methods" "combination" "default-method" } reset-props ;
|
||||
|
||||
: gensym ( -- word )
|
||||
"G:" \ gensym counter number>string append f <word> ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,6 @@
|
|||
USING: assocs kernel vectors sequences ;
|
||||
USING: assocs kernel vectors sequences namespaces ;
|
||||
IN: assocs.lib
|
||||
|
||||
: insert-at ( value key assoc -- )
|
||||
[ ?push ] change-at ;
|
||||
|
||||
: >set ( seq -- hash )
|
||||
[ dup ] H{ } map>assoc ;
|
||||
|
||||
|
|
@ -19,5 +16,19 @@ IN: assocs.lib
|
|||
: at-default ( key assoc -- value/key )
|
||||
dupd at [ nip ] when* ;
|
||||
|
||||
: at-peek ( key assoc -- value ? )
|
||||
at* dup >r [ peek ] when r> ;
|
||||
: insert-at ( value key assoc -- )
|
||||
[ ?push ] change-at ;
|
||||
|
||||
: peek-at* ( key assoc -- obj ? )
|
||||
at* dup [ >r peek r> ] when ;
|
||||
|
||||
: peek-at ( key assoc -- obj )
|
||||
peek-at* drop ;
|
||||
|
||||
: >multi-assoc ( assoc -- new-assoc )
|
||||
[ 1vector ] assoc-map ;
|
||||
|
||||
: multi-assoc-each ( assoc quot -- )
|
||||
[ with each ] curry assoc-each ; inline
|
||||
|
||||
: insert ( value variable -- ) namespace insert-at ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
|
||||
USING: kernel math math.parser random arrays hashtables assocs sequences
|
||||
vars strings.lib ;
|
||||
vars ;
|
||||
|
||||
IN: automata
|
||||
|
||||
|
|
@ -108,4 +108,4 @@ last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ;
|
|||
|
||||
! : start-loop ( -- ) t >loop-flag [ loop ] in-thread ;
|
||||
|
||||
! : stop-loop ( -- ) f >loop-flag ;
|
||||
! : stop-loop ( -- ) f >loop-flag ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,77 @@
|
|||
USING: classes kernel sequences vocabs math ;
|
||||
IN: benchmark.dispatch5
|
||||
|
||||
MIXIN: g
|
||||
|
||||
TUPLE: x1 ;
|
||||
INSTANCE: x1 g
|
||||
TUPLE: x2 ;
|
||||
INSTANCE: x2 g
|
||||
TUPLE: x3 ;
|
||||
INSTANCE: x3 g
|
||||
TUPLE: x4 ;
|
||||
INSTANCE: x4 g
|
||||
TUPLE: x5 ;
|
||||
INSTANCE: x5 g
|
||||
TUPLE: x6 ;
|
||||
INSTANCE: x6 g
|
||||
TUPLE: x7 ;
|
||||
INSTANCE: x7 g
|
||||
TUPLE: x8 ;
|
||||
INSTANCE: x8 g
|
||||
TUPLE: x9 ;
|
||||
INSTANCE: x9 g
|
||||
TUPLE: x10 ;
|
||||
INSTANCE: x10 g
|
||||
TUPLE: x11 ;
|
||||
INSTANCE: x11 g
|
||||
TUPLE: x12 ;
|
||||
INSTANCE: x12 g
|
||||
TUPLE: x13 ;
|
||||
INSTANCE: x13 g
|
||||
TUPLE: x14 ;
|
||||
INSTANCE: x14 g
|
||||
TUPLE: x15 ;
|
||||
INSTANCE: x15 g
|
||||
TUPLE: x16 ;
|
||||
INSTANCE: x16 g
|
||||
TUPLE: x17 ;
|
||||
INSTANCE: x17 g
|
||||
TUPLE: x18 ;
|
||||
INSTANCE: x18 g
|
||||
TUPLE: x19 ;
|
||||
INSTANCE: x19 g
|
||||
TUPLE: x20 ;
|
||||
INSTANCE: x20 g
|
||||
TUPLE: x21 ;
|
||||
INSTANCE: x21 g
|
||||
TUPLE: x22 ;
|
||||
INSTANCE: x22 g
|
||||
TUPLE: x23 ;
|
||||
INSTANCE: x23 g
|
||||
TUPLE: x24 ;
|
||||
INSTANCE: x24 g
|
||||
TUPLE: x25 ;
|
||||
INSTANCE: x25 g
|
||||
TUPLE: x26 ;
|
||||
INSTANCE: x26 g
|
||||
TUPLE: x27 ;
|
||||
INSTANCE: x27 g
|
||||
TUPLE: x28 ;
|
||||
INSTANCE: x28 g
|
||||
TUPLE: x29 ;
|
||||
INSTANCE: x29 g
|
||||
TUPLE: x30 ;
|
||||
INSTANCE: x30 g
|
||||
|
||||
: my-classes ( -- seq )
|
||||
"benchmark.dispatch5" words [ tuple-class? ] subset ;
|
||||
|
||||
: a-bunch-of-objects ( -- seq )
|
||||
my-classes [ construct-empty ] map ;
|
||||
|
||||
: dispatch-benchmark ( -- )
|
||||
1000000 a-bunch-of-objects
|
||||
[ f [ g? or ] reduce drop ] curry times ;
|
||||
|
||||
MAIN: dispatch-benchmark
|
||||
|
|
@ -1 +1,2 @@
|
|||
Slava Pestov
|
||||
Joe Groff
|
||||
|
|
|
|||
|
|
@ -1,112 +1,69 @@
|
|||
! From http://www.ffconsultancy.com/ocaml/bunny/index.html
|
||||
USING: alien alien.c-types arrays sequences math
|
||||
math.vectors math.matrices math.parser io io.files kernel opengl
|
||||
opengl.gl opengl.glu shuffle http.client vectors timers
|
||||
namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting
|
||||
combinators tools.time system combinators.lib ;
|
||||
combinators tools.time system combinators.lib combinators.cleave
|
||||
float-arrays continuations opengl.demo-support multiline
|
||||
ui.gestures
|
||||
bunny.fixed-pipeline bunny.cel-shaded bunny.outlined bunny.model ;
|
||||
IN: bunny
|
||||
|
||||
: numbers ( str -- seq )
|
||||
" " split [ string>number ] map [ ] subset ;
|
||||
TUPLE: bunny-gadget model geom draw-seq draw-n ;
|
||||
|
||||
: (parse-model) ( vs is -- vs is )
|
||||
readln [
|
||||
numbers {
|
||||
{ [ dup length 5 = ] [ 3 head pick push ] }
|
||||
{ [ dup first 3 = ] [ 1 tail over push ] }
|
||||
{ [ t ] [ drop ] }
|
||||
} cond (parse-model)
|
||||
] when* ;
|
||||
: <bunny-gadget> ( -- bunny-gadget )
|
||||
0.0 0.0 0.375 <demo-gadget>
|
||||
maybe-download read-model {
|
||||
set-delegate
|
||||
set-bunny-gadget-model
|
||||
} bunny-gadget construct ;
|
||||
|
||||
: parse-model ( stream -- vs is )
|
||||
[
|
||||
100000 <vector> 100000 <vector> (parse-model)
|
||||
] with-stream
|
||||
[
|
||||
over length # " vertices, " %
|
||||
dup length # " triangles" %
|
||||
] "" make print ;
|
||||
: bunny-gadget-draw ( gadget -- draw )
|
||||
{ bunny-gadget-draw-n bunny-gadget-draw-seq }
|
||||
get-slots nth ;
|
||||
|
||||
: n ( vs triple -- n )
|
||||
swap [ nth ] curry map
|
||||
dup third over first v- >r dup second swap first v- r> cross
|
||||
vneg normalize ;
|
||||
: bunny-gadget-next-draw ( gadget -- )
|
||||
dup { bunny-gadget-draw-seq bunny-gadget-draw-n }
|
||||
get-slots
|
||||
1+ swap length mod
|
||||
swap [ set-bunny-gadget-draw-n ] keep relayout-1 ;
|
||||
|
||||
: normal ( ns vs triple -- )
|
||||
[ n ] keep [ rot [ v+ ] change-nth ] each-with2 ;
|
||||
|
||||
: normals ( vs is -- ns )
|
||||
over length { 0.0 0.0 0.0 } <array> -rot
|
||||
[ >r 2dup r> normal ] each drop
|
||||
[ normalize ] map ;
|
||||
|
||||
: read-model ( stream -- model )
|
||||
"Reading model" print flush [
|
||||
<file-reader> parse-model [ normals ] 2keep 3array
|
||||
] time ;
|
||||
|
||||
: model-path "bun_zipper.ply" ;
|
||||
|
||||
: model-url "http://factorcode.org/bun_zipper.ply" ;
|
||||
|
||||
: maybe-download ( -- path )
|
||||
model-path resource-path dup exists? [
|
||||
"Downloading bunny from " write
|
||||
model-url dup print flush
|
||||
over download-to
|
||||
] unless ;
|
||||
|
||||
: draw-triangle ( ns vs triple -- )
|
||||
[ dup roll nth gl-normal swap nth gl-vertex ] each-with2 ;
|
||||
|
||||
: draw-bunny ( ns vs is -- )
|
||||
GL_TRIANGLES [ [ draw-triangle ] each-with2 ] do-state ;
|
||||
|
||||
TUPLE: bunny-gadget model ;
|
||||
|
||||
: <bunny-gadget> ( model -- gadget )
|
||||
<canvas>
|
||||
{ set-bunny-gadget-model set-delegate }
|
||||
bunny-gadget construct ;
|
||||
|
||||
M: bunny-gadget graft* 10 10 add-timer ;
|
||||
|
||||
M: bunny-gadget ungraft* dup delegate ungraft* remove-timer ;
|
||||
|
||||
M: bunny-gadget tick relayout-1 ;
|
||||
|
||||
: aspect ( gadget -- x ) rect-dim first2 /f ;
|
||||
|
||||
M: bunny-gadget draw-gadget*
|
||||
M: bunny-gadget graft* ( gadget -- )
|
||||
GL_DEPTH_TEST glEnable
|
||||
GL_SCISSOR_TEST glDisable
|
||||
1.0 glClearDepth
|
||||
0.0 0.0 0.0 1.0 glClearColor
|
||||
GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
45.0 over aspect 0.1 1.0 gluPerspective
|
||||
0.0 0.12 -0.25 0.0 0.1 0.0 0.0 1.0 0.0 gluLookAt
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity
|
||||
GL_LEQUAL glDepthFunc
|
||||
GL_LIGHTING glEnable
|
||||
GL_LIGHT0 glEnable
|
||||
GL_COLOR_MATERIAL glEnable
|
||||
GL_LIGHT0 GL_POSITION { 1.0 -1.0 1.0 1.0 } >c-float-array glLightfv
|
||||
millis 24000 mod 0.015 * 0.0 1.0 0.0 glRotated
|
||||
GL_FRONT_AND_BACK GL_SHININESS 100.0 glMaterialf
|
||||
GL_FRONT_AND_BACK GL_SPECULAR glColorMaterial
|
||||
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial
|
||||
0.6 0.5 0.5 1.0 glColor4d
|
||||
[ bunny-gadget-model first3 draw-bunny ] draw-canvas ;
|
||||
dup bunny-gadget-model <bunny-geom>
|
||||
over {
|
||||
[ <bunny-fixed-pipeline> ]
|
||||
[ <bunny-cel-shaded> ]
|
||||
[ <bunny-outlined> ]
|
||||
} map-call-with [ ] subset
|
||||
0
|
||||
roll {
|
||||
set-bunny-gadget-geom
|
||||
set-bunny-gadget-draw-seq
|
||||
set-bunny-gadget-draw-n
|
||||
} set-slots ;
|
||||
|
||||
M: bunny-gadget pref-dim* drop { 400 300 } ;
|
||||
M: bunny-gadget ungraft* ( gadget -- )
|
||||
{ bunny-gadget-geom bunny-gadget-draw-seq } get-slots
|
||||
[ [ dispose ] when* ] each
|
||||
[ dispose ] when* ;
|
||||
|
||||
M: bunny-gadget draw-gadget* ( gadget -- )
|
||||
0.15 0.15 0.15 1.0 glClearColor
|
||||
GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
|
||||
dup demo-gadget-set-matrices
|
||||
GL_MODELVIEW glMatrixMode
|
||||
0.02 -0.105 0.0 glTranslatef
|
||||
{ bunny-gadget-geom bunny-gadget-draw } get-slots
|
||||
draw-bunny ;
|
||||
|
||||
M: bunny-gadget pref-dim* ( gadget -- dim )
|
||||
drop { 640 480 } ;
|
||||
|
||||
bunny-gadget H{
|
||||
{ T{ key-down f f "TAB" } [ bunny-gadget-next-draw ] }
|
||||
} set-gestures
|
||||
|
||||
: bunny-window ( -- )
|
||||
[
|
||||
maybe-download read-model <bunny-gadget>
|
||||
"Bunny" open-window
|
||||
] with-ui ;
|
||||
[ <bunny-gadget> "Bunny" open-window ] with-ui ;
|
||||
|
||||
MAIN: bunny-window
|
||||
|
|
|
|||
|
|
@ -0,0 +1,93 @@
|
|||
USING: arrays bunny.model combinators.lib continuations
|
||||
kernel multiline opengl opengl.shaders opengl.capabilities
|
||||
opengl.gl sequences ;
|
||||
IN: bunny.cel-shaded
|
||||
|
||||
STRING: vertex-shader-source
|
||||
varying vec3 position, normal, viewer;
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
gl_Position = ftransform();
|
||||
|
||||
position = gl_Vertex.xyz;
|
||||
normal = gl_Normal;
|
||||
viewer = vec3(0, 0, 1) * gl_NormalMatrix;
|
||||
}
|
||||
|
||||
;
|
||||
|
||||
STRING: cel-shaded-fragment-shader-lib-source
|
||||
varying vec3 position, normal, viewer;
|
||||
uniform vec3 light_direction;
|
||||
uniform vec4 color;
|
||||
uniform vec4 ambient, diffuse;
|
||||
uniform float shininess;
|
||||
|
||||
float
|
||||
modulate(vec3 direction, vec3 normal)
|
||||
{
|
||||
return dot(direction, normal) * 0.5 + 0.5;
|
||||
}
|
||||
|
||||
float
|
||||
cel(float m)
|
||||
{
|
||||
return smoothstep(0.25, 0.255, m) * 0.4 + smoothstep(0.695, 0.70, m) * 0.5;
|
||||
}
|
||||
|
||||
vec4
|
||||
cel_light()
|
||||
{
|
||||
vec3 direction = normalize(light_direction - position);
|
||||
vec3 reflection = reflect(direction, normal);
|
||||
vec4 ad = (ambient + diffuse * vec4(vec3(cel(modulate(direction, normal))), 1));
|
||||
float s = cel(pow(max(dot(-reflection, viewer), 0.0), shininess));
|
||||
return ad * color + vec4(vec3(s), 0);
|
||||
}
|
||||
|
||||
;
|
||||
|
||||
STRING: cel-shaded-fragment-shader-main-source
|
||||
vec4 cel_light();
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
gl_FragColor = cel_light();
|
||||
}
|
||||
|
||||
;
|
||||
|
||||
TUPLE: bunny-cel-shaded program ;
|
||||
|
||||
: cel-shading-supported? ( -- ? )
|
||||
"2.0" { "GL_ARB_shader_objects" }
|
||||
has-gl-version-or-extensions? ;
|
||||
|
||||
: <bunny-cel-shaded> ( gadget -- draw )
|
||||
drop
|
||||
cel-shading-supported? [
|
||||
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
|
||||
] [ f ] if ;
|
||||
|
||||
: (draw-cel-shaded-bunny) ( geom program -- )
|
||||
{
|
||||
{ "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] }
|
||||
{ "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] }
|
||||
{ "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] }
|
||||
{ "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] }
|
||||
{ "shininess" [ 100.0 glUniform1f ] }
|
||||
} [ bunny-geom ] with-gl-program ;
|
||||
|
||||
M: bunny-cel-shaded draw-bunny
|
||||
bunny-cel-shaded-program (draw-cel-shaded-bunny) ;
|
||||
|
||||
M: bunny-cel-shaded dispose
|
||||
bunny-cel-shaded-program delete-gl-program ;
|
||||
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
USING: alien.c-types continuations kernel
|
||||
opengl opengl.gl bunny.model ;
|
||||
IN: bunny.fixed-pipeline
|
||||
|
||||
TUPLE: bunny-fixed-pipeline ;
|
||||
|
||||
: <bunny-fixed-pipeline> ( gadget -- draw )
|
||||
drop
|
||||
{ } bunny-fixed-pipeline construct ;
|
||||
|
||||
M: bunny-fixed-pipeline draw-bunny
|
||||
drop
|
||||
GL_LIGHTING glEnable
|
||||
GL_LIGHT0 glEnable
|
||||
GL_COLOR_MATERIAL glEnable
|
||||
GL_LIGHT0 GL_POSITION { 1.0 -1.0 1.0 1.0 } >c-float-array glLightfv
|
||||
GL_FRONT_AND_BACK GL_SHININESS 100.0 glMaterialf
|
||||
GL_FRONT_AND_BACK GL_SPECULAR glColorMaterial
|
||||
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial
|
||||
0.6 0.5 0.5 1.0 glColor4f
|
||||
bunny-geom ;
|
||||
|
||||
M: bunny-fixed-pipeline dispose
|
||||
drop ;
|
||||
|
||||
|
|
@ -0,0 +1,114 @@
|
|||
USING: alien alien.c-types arrays sequences math
|
||||
math.vectors math.matrices math.parser io io.files kernel opengl
|
||||
opengl.gl opengl.glu opengl.capabilities shuffle http.client
|
||||
vectors splitting
|
||||
tools.time system combinators combinators.lib combinators.cleave
|
||||
float-arrays continuations namespaces ;
|
||||
IN: bunny.model
|
||||
|
||||
: numbers ( str -- seq )
|
||||
" " split [ string>number ] map [ ] subset ;
|
||||
|
||||
: (parse-model) ( vs is -- vs is )
|
||||
readln [
|
||||
numbers {
|
||||
{ [ dup length 5 = ] [ 3 head pick push ] }
|
||||
{ [ dup first 3 = ] [ 1 tail over push ] }
|
||||
{ [ t ] [ drop ] }
|
||||
} cond (parse-model)
|
||||
] when* ;
|
||||
|
||||
: parse-model ( stream -- vs is )
|
||||
[
|
||||
100000 <vector> 100000 <vector> (parse-model)
|
||||
] with-stream
|
||||
[
|
||||
over length # " vertices, " %
|
||||
dup length # " triangles" %
|
||||
] "" make print ;
|
||||
|
||||
: n ( vs triple -- n )
|
||||
swap [ nth ] curry map
|
||||
dup third over first v- >r dup second swap first v- r> cross
|
||||
vneg normalize ;
|
||||
|
||||
: normal ( ns vs triple -- )
|
||||
[ n ] keep [ rot [ v+ ] change-nth ] each-with2 ;
|
||||
|
||||
: normals ( vs is -- ns )
|
||||
over length { 0.0 0.0 0.0 } <array> -rot
|
||||
[ >r 2dup r> normal ] each drop
|
||||
[ normalize ] map ;
|
||||
|
||||
: read-model ( stream -- model )
|
||||
"Reading model" print flush [
|
||||
<file-reader> parse-model [ normals ] 2keep 3array
|
||||
] time ;
|
||||
|
||||
: model-path "bun_zipper.ply" ;
|
||||
|
||||
: model-url "http://factorcode.org/bun_zipper.ply" ;
|
||||
|
||||
: maybe-download ( -- path )
|
||||
model-path resource-path dup exists? [
|
||||
"Downloading bunny from " write
|
||||
model-url dup print flush
|
||||
over download-to
|
||||
] unless ;
|
||||
|
||||
: (draw-triangle) ( ns vs triple -- )
|
||||
[ dup roll nth gl-normal swap nth gl-vertex ] each-with2 ;
|
||||
|
||||
: draw-triangles ( ns vs is -- )
|
||||
GL_TRIANGLES [ [ (draw-triangle) ] each-with2 ] do-state ;
|
||||
|
||||
TUPLE: bunny-dlist list ;
|
||||
TUPLE: bunny-buffers array element-array nv ni ;
|
||||
|
||||
: <bunny-dlist> ( model -- geom )
|
||||
GL_COMPILE [ first3 draw-triangles ] make-dlist
|
||||
bunny-dlist construct-boa ;
|
||||
|
||||
: <bunny-buffers> ( model -- geom )
|
||||
[
|
||||
[ first concat ] [ second concat ] bi
|
||||
append >float-array
|
||||
GL_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
|
||||
] [
|
||||
third concat >c-uint-array
|
||||
GL_ELEMENT_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
|
||||
]
|
||||
[ first length 3 * ] [ third length 3 * ] tetra
|
||||
bunny-buffers construct-boa ;
|
||||
|
||||
GENERIC: bunny-geom ( geom -- )
|
||||
GENERIC: draw-bunny ( geom draw -- )
|
||||
|
||||
M: bunny-dlist bunny-geom
|
||||
bunny-dlist-list glCallList ;
|
||||
|
||||
M: bunny-buffers bunny-geom
|
||||
dup {
|
||||
bunny-buffers-array
|
||||
bunny-buffers-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
|
||||
] all-enabled-client-state
|
||||
] with-array-element-buffers ;
|
||||
|
||||
M: bunny-dlist dispose
|
||||
bunny-dlist-list delete-dlist ;
|
||||
|
||||
M: bunny-buffers dispose
|
||||
{ bunny-buffers-array bunny-buffers-element-array } get-slots
|
||||
delete-gl-buffer delete-gl-buffer ;
|
||||
|
||||
: <bunny-geom> ( model -- geom )
|
||||
"1.5" { "GL_ARB_vertex_buffer_object" }
|
||||
has-gl-version-or-extensions?
|
||||
[ <bunny-buffers> ] [ <bunny-dlist> ] if ;
|
||||
|
|
@ -0,0 +1,240 @@
|
|||
USING: arrays bunny.model bunny.cel-shaded
|
||||
combinators.lib continuations kernel math multiline
|
||||
opengl opengl.shaders opengl.framebuffers opengl.gl
|
||||
opengl.capabilities sequences ui.gadgets ;
|
||||
IN: bunny.outlined
|
||||
|
||||
STRING: outlined-pass1-fragment-shader-main-source
|
||||
varying vec3 normal;
|
||||
vec4 cel_light();
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
gl_FragData[0] = cel_light();
|
||||
gl_FragData[1] = vec4(normal, 1);
|
||||
}
|
||||
|
||||
;
|
||||
|
||||
STRING: outlined-pass2-vertex-shader-source
|
||||
varying vec2 coord;
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
gl_Position = ftransform();
|
||||
coord = (gl_Vertex * vec4(0.5) + vec4(0.5)).xy;
|
||||
}
|
||||
|
||||
;
|
||||
|
||||
STRING: outlined-pass2-fragment-shader-source
|
||||
uniform sampler2D colormap, normalmap, depthmap;
|
||||
uniform vec4 line_color;
|
||||
varying vec2 coord;
|
||||
|
||||
const float DEPTH_RATIO_THRESHOLD = 1.001, SAMPLE_SPREAD = 1.0/512.0;
|
||||
|
||||
float
|
||||
depth_sample(vec2 c)
|
||||
{
|
||||
return texture2D(depthmap, c).x;
|
||||
}
|
||||
bool
|
||||
are_depths_border(vec3 depths)
|
||||
{
|
||||
return any(lessThan(depths, vec3(1.0/DEPTH_RATIO_THRESHOLD)))
|
||||
|| any(greaterThan(depths, vec3(DEPTH_RATIO_THRESHOLD)));
|
||||
}
|
||||
|
||||
vec3
|
||||
normal_sample(vec2 c)
|
||||
{
|
||||
return texture2D(normalmap, c).xyz;
|
||||
}
|
||||
|
||||
float
|
||||
min6(float a, float b, float c, float d, float e, float f)
|
||||
{
|
||||
return min(min(min(min(min(a, b), c), d), e), f);
|
||||
}
|
||||
|
||||
float
|
||||
border_factor(vec2 c)
|
||||
{
|
||||
vec2 coord1 = c + vec2(-SAMPLE_SPREAD, -SAMPLE_SPREAD),
|
||||
coord2 = c + vec2( SAMPLE_SPREAD, -SAMPLE_SPREAD),
|
||||
coord3 = c + vec2(-SAMPLE_SPREAD, SAMPLE_SPREAD),
|
||||
coord4 = c + vec2( SAMPLE_SPREAD, SAMPLE_SPREAD);
|
||||
|
||||
vec3 normal1 = normal_sample(coord1),
|
||||
normal2 = normal_sample(coord2),
|
||||
normal3 = normal_sample(coord3),
|
||||
normal4 = normal_sample(coord4);
|
||||
|
||||
if (dot(normal1, normal1) < 0.5
|
||||
&& dot(normal2, normal2) < 0.5
|
||||
&& dot(normal3, normal3) < 0.5
|
||||
&& dot(normal4, normal4) < 0.5) {
|
||||
return 0.0;
|
||||
} else {
|
||||
vec4 depths = vec4(depth_sample(coord1),
|
||||
depth_sample(coord2),
|
||||
depth_sample(coord3),
|
||||
depth_sample(coord4));
|
||||
|
||||
vec3 ratios1 = depths.xxx/depths.yzw, ratios2 = depths.yyz/depths.zww;
|
||||
|
||||
if (are_depths_border(ratios1) || are_depths_border(ratios2)) {
|
||||
return 1.0;
|
||||
} else {
|
||||
float normal_border = 1.0 - min6(
|
||||
dot(normal1, normal2),
|
||||
dot(normal1, normal3),
|
||||
dot(normal1, normal4),
|
||||
dot(normal2, normal3),
|
||||
dot(normal2, normal4),
|
||||
dot(normal3, normal4)
|
||||
);
|
||||
|
||||
return normal_border;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
gl_FragColor = mix(texture2D(colormap, coord), line_color, border_factor(coord));
|
||||
}
|
||||
|
||||
;
|
||||
|
||||
TUPLE: bunny-outlined
|
||||
gadget
|
||||
pass1-program pass2-program
|
||||
color-texture normal-texture depth-texture
|
||||
framebuffer framebuffer-dim ;
|
||||
|
||||
: outlining-supported? ( -- ? )
|
||||
"2.0" {
|
||||
"GL_ARB_shading_objects"
|
||||
"GL_ARB_draw_buffers"
|
||||
"GL_ARB_multitexture"
|
||||
} has-gl-version-or-extensions? {
|
||||
"GL_EXT_framebuffer_object"
|
||||
"GL_ARB_texture_float"
|
||||
} has-gl-extensions? and ;
|
||||
|
||||
: pass1-program ( -- program )
|
||||
vertex-shader-source <vertex-shader> check-gl-shader
|
||||
cel-shaded-fragment-shader-lib-source <fragment-shader> check-gl-shader
|
||||
outlined-pass1-fragment-shader-main-source <fragment-shader> check-gl-shader
|
||||
3array <gl-program> check-gl-program ;
|
||||
|
||||
: pass2-program ( -- program )
|
||||
outlined-pass2-vertex-shader-source
|
||||
outlined-pass2-fragment-shader-source <simple-gl-program> ;
|
||||
|
||||
: <bunny-outlined> ( gadget -- draw )
|
||||
outlining-supported? [
|
||||
pass1-program pass2-program {
|
||||
set-bunny-outlined-gadget
|
||||
set-bunny-outlined-pass1-program
|
||||
set-bunny-outlined-pass2-program
|
||||
} bunny-outlined construct
|
||||
] [ drop f ] if ;
|
||||
|
||||
: (framebuffer-texture) ( dim iformat xformat -- texture )
|
||||
swapd >r >r >r
|
||||
GL_TEXTURE0 glActiveTexture
|
||||
gen-texture GL_TEXTURE_2D over glBindTexture
|
||||
GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
|
||||
GL_TEXTURE_2D 0 r> r> first2 0 r> GL_UNSIGNED_BYTE f glTexImage2D ;
|
||||
|
||||
: (attach-framebuffer-texture) ( texture attachment -- )
|
||||
swap >r >r
|
||||
GL_FRAMEBUFFER_EXT r> GL_TEXTURE_2D r> 0 glFramebufferTexture2DEXT
|
||||
gl-error ;
|
||||
|
||||
: (make-framebuffer) ( color-texture normal-texture depth-texture -- framebuffer )
|
||||
3array gen-framebuffer dup [
|
||||
swap GL_COLOR_ATTACHMENT0_EXT
|
||||
GL_COLOR_ATTACHMENT1_EXT
|
||||
GL_DEPTH_ATTACHMENT_EXT 3array [ (attach-framebuffer-texture) ] 2each
|
||||
check-framebuffer
|
||||
] with-framebuffer ;
|
||||
|
||||
: dispose-framebuffer ( draw -- )
|
||||
dup bunny-outlined-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 ]
|
||||
} call-with
|
||||
] [ drop ] if ;
|
||||
|
||||
: remake-framebuffer-if-needed ( draw -- )
|
||||
dup bunny-outlined-gadget rect-dim
|
||||
over bunny-outlined-framebuffer-dim
|
||||
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
|
||||
] if ;
|
||||
|
||||
: clear-framebuffer ( -- )
|
||||
GL_COLOR_ATTACHMENT0_EXT glDrawBuffer
|
||||
0.15 0.15 0.15 1.0 glClearColor
|
||||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
|
||||
GL_COLOR_ATTACHMENT1_EXT glDrawBuffer
|
||||
0.0 0.0 0.0 0.0 glClearColor
|
||||
GL_COLOR_BUFFER_BIT glClear ;
|
||||
|
||||
: (pass1) ( geom draw -- )
|
||||
dup bunny-outlined-framebuffer [
|
||||
clear-framebuffer
|
||||
{ GL_COLOR_ATTACHMENT0_EXT GL_COLOR_ATTACHMENT1_EXT } set-draw-buffers
|
||||
bunny-outlined-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 ;
|
||||
|
||||
M: bunny-outlined draw-bunny
|
||||
dup remake-framebuffer-if-needed
|
||||
[ (pass1) ] keep (pass2) ;
|
||||
|
||||
M: bunny-outlined dispose
|
||||
{
|
||||
[ bunny-outlined-pass1-program [ delete-gl-program ] when* ]
|
||||
[ bunny-outlined-pass2-program [ delete-gl-program ] when* ]
|
||||
[ dispose-framebuffer ]
|
||||
} call-with ;
|
||||
|
|
@ -1 +1,2 @@
|
|||
demos
|
||||
opengl
|
||||
|
|
|
|||
|
|
@ -1,89 +0,0 @@
|
|||
USING: arrays bunny combinators.lib io io.files kernel
|
||||
math math.functions multiline continuations debugger
|
||||
opengl opengl.gl opengl-demo-support
|
||||
sequences ui ui.gadgets ui.render ;
|
||||
IN: cel-shading
|
||||
|
||||
TUPLE: cel-shading-gadget model program ;
|
||||
|
||||
: <cel-shading-gadget> ( -- cel-shading-gadget )
|
||||
0.0 0.0 0.375 <demo-gadget>
|
||||
maybe-download read-model
|
||||
{ set-delegate set-cel-shading-gadget-model } cel-shading-gadget construct ;
|
||||
|
||||
STRING: cel-shading-vertex-shader-source
|
||||
varying vec3 position, normal;
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
gl_Position = ftransform();
|
||||
|
||||
position = gl_Vertex.xyz;
|
||||
normal = gl_Normal;
|
||||
}
|
||||
|
||||
;
|
||||
|
||||
STRING: cel-shading-fragment-shader-source
|
||||
varying vec3 position, normal;
|
||||
uniform vec3 light_direction;
|
||||
uniform vec4 color;
|
||||
uniform vec4 ambient, diffuse;
|
||||
|
||||
float
|
||||
smooth_modulate(vec3 direction, vec3 normal)
|
||||
{
|
||||
return clamp(dot(direction, normal), 0.0, 1.0);
|
||||
}
|
||||
|
||||
float
|
||||
modulate(vec3 direction, vec3 normal)
|
||||
{
|
||||
float m = smooth_modulate(direction, normal);
|
||||
return smoothstep(0.0, 0.01, m) * 0.4 + smoothstep(0.49, 0.5, m) * 0.5;
|
||||
}
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
vec3 direction = normalize(light_direction - position);
|
||||
gl_FragColor = ambient + diffuse * color * vec4(vec3(modulate(direction, normal)), 1);
|
||||
}
|
||||
|
||||
;
|
||||
|
||||
: cel-shading-program ( -- program )
|
||||
cel-shading-vertex-shader-source cel-shading-fragment-shader-source
|
||||
<simple-gl-program> ;
|
||||
|
||||
M: cel-shading-gadget graft* ( gadget -- )
|
||||
[ "2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions
|
||||
0.0 0.0 0.0 1.0 glClearColor
|
||||
GL_CULL_FACE glEnable
|
||||
GL_DEPTH_TEST glEnable
|
||||
cel-shading-program swap set-cel-shading-gadget-program ] [ ] [ :c ] cleanup ;
|
||||
|
||||
M: cel-shading-gadget ungraft* ( gadget -- )
|
||||
cel-shading-gadget-program [ delete-gl-program ] when* ;
|
||||
|
||||
: cel-shading-draw-setup ( gadget -- gadget )
|
||||
[ demo-gadget-set-matrices ] keep
|
||||
[ cel-shading-gadget-program
|
||||
{ [ "light_direction" glGetUniformLocation -25.0 45.0 80.0 glUniform3f ]
|
||||
[ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ]
|
||||
[ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ]
|
||||
[ "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ] } call-with
|
||||
] keep ;
|
||||
|
||||
M: cel-shading-gadget draw-gadget* ( gadget -- )
|
||||
dup cel-shading-gadget-program [
|
||||
cel-shading-draw-setup
|
||||
0.0 -0.12 0.0 glTranslatef
|
||||
cel-shading-gadget-model first3 draw-bunny
|
||||
] with-gl-program ;
|
||||
|
||||
: cel-shading-window ( -- )
|
||||
[ <cel-shading-gadget> "Cel Shading" open-window ] with-ui ;
|
||||
|
||||
MAIN: cel-shading-window
|
||||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types arrays kernel math namespaces cocoa
|
||||
cocoa.messages cocoa.classes cocoa.types sequences ;
|
||||
cocoa.messages cocoa.classes cocoa.types sequences
|
||||
continuations ;
|
||||
IN: cocoa.views
|
||||
|
||||
: NSOpenGLPFAAllRenderers 1 ;
|
||||
|
|
@ -35,11 +36,23 @@ IN: cocoa.views
|
|||
: NSOpenGLPFAPixelBuffer 90 ;
|
||||
: NSOpenGLPFAVirtualScreenCount 128 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: +software-renderer+
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: with-software-renderer ( quot -- )
|
||||
t +software-renderer+ set
|
||||
[ f +software-renderer+ set ]
|
||||
[ ] cleanup ; inline
|
||||
|
||||
: <PixelFormat> ( -- pixelfmt )
|
||||
NSOpenGLPixelFormat -> alloc [
|
||||
NSOpenGLPFAWindow ,
|
||||
NSOpenGLPFADoubleBuffer ,
|
||||
NSOpenGLPFADepthSize , 16 ,
|
||||
+software-renderer+ get [ NSOpenGLPFARobust , ] when
|
||||
0 ,
|
||||
] { } make >c-int-array
|
||||
-> initWithAttributes:
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math cocoa cocoa.messages cocoa.classes
|
||||
sequences ;
|
||||
sequences math.bitfields ;
|
||||
IN: cocoa.windows
|
||||
|
||||
: NSBorderlessWindowMask 0 ; inline
|
||||
|
|
@ -15,10 +15,12 @@ IN: cocoa.windows
|
|||
: NSBackingStoreBuffered 2 ; inline
|
||||
|
||||
: standard-window-type
|
||||
NSTitledWindowMask
|
||||
NSClosableWindowMask bitor
|
||||
NSMiniaturizableWindowMask bitor
|
||||
NSResizableWindowMask bitor ; inline
|
||||
{
|
||||
NSTitledWindowMask
|
||||
NSClosableWindowMask
|
||||
NSMiniaturizableWindowMask
|
||||
NSResizableWindowMask
|
||||
} flags ; inline
|
||||
|
||||
: <NSWindow> ( rect -- window )
|
||||
NSWindow -> alloc swap
|
||||
|
|
|
|||
|
|
@ -0,0 +1,104 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs classes continuations kernel math
|
||||
namespaces sequences sequences.lib tuples words ;
|
||||
IN: db
|
||||
|
||||
TUPLE: db handle ;
|
||||
C: <db> db ( handle -- obj )
|
||||
|
||||
! HOOK: db-create db ( str -- )
|
||||
! HOOK: db-drop db ( str -- )
|
||||
GENERIC: db-open ( db -- )
|
||||
GENERIC: db-close ( db -- )
|
||||
|
||||
TUPLE: statement sql params handle bound? ;
|
||||
|
||||
TUPLE: simple-statement ;
|
||||
TUPLE: prepared-statement ;
|
||||
|
||||
HOOK: <simple-statement> db ( str -- statement )
|
||||
HOOK: <prepared-statement> db ( str -- statement )
|
||||
|
||||
GENERIC: prepare-statement ( statement -- )
|
||||
GENERIC: bind-statement* ( obj statement -- )
|
||||
GENERIC: rebind-statement ( obj statement -- )
|
||||
|
||||
GENERIC: execute-statement ( statement -- )
|
||||
|
||||
: bind-statement ( obj statement -- )
|
||||
2dup dup statement-bound? [
|
||||
rebind-statement
|
||||
] [
|
||||
bind-statement*
|
||||
] if
|
||||
tuck set-statement-params
|
||||
t swap set-statement-bound? ;
|
||||
|
||||
TUPLE: result-set sql params handle n max ;
|
||||
|
||||
GENERIC: query-results ( query -- result-set )
|
||||
|
||||
GENERIC: #rows ( result-set -- n )
|
||||
GENERIC: #columns ( result-set -- n )
|
||||
GENERIC# row-column 1 ( result-set n -- obj )
|
||||
GENERIC: advance-row ( result-set -- ? )
|
||||
|
||||
: init-result-set ( result-set -- )
|
||||
dup #rows over set-result-set-max
|
||||
-1 swap set-result-set-n ;
|
||||
|
||||
: <result-set> ( query handle tuple -- result-set )
|
||||
>r >r { statement-sql statement-params } get-slots r>
|
||||
{
|
||||
set-result-set-sql
|
||||
set-result-set-params
|
||||
set-result-set-handle
|
||||
} result-set construct r> construct-delegate ;
|
||||
|
||||
: sql-row ( result-set -- seq )
|
||||
dup #columns [ row-column ] with map ;
|
||||
|
||||
: query-each ( statement quot -- )
|
||||
over advance-row [
|
||||
2drop
|
||||
] [
|
||||
[ call ] 2keep query-each
|
||||
] if ; inline
|
||||
|
||||
: query-map ( statement quot -- seq )
|
||||
accumulator >r query-each r> { } like ; inline
|
||||
|
||||
: with-db ( db quot -- )
|
||||
[
|
||||
over db-open
|
||||
[ db swap with-variable ] curry with-disposal
|
||||
] with-scope ;
|
||||
|
||||
: do-query ( query -- result-set )
|
||||
query-results [ [ sql-row ] query-map ] with-disposal ;
|
||||
|
||||
: do-bound-query ( obj query -- rows )
|
||||
[ bind-statement ] keep do-query ;
|
||||
|
||||
: do-bound-command ( obj query -- )
|
||||
[ bind-statement ] keep execute-statement ;
|
||||
|
||||
: sql-query ( sql -- rows )
|
||||
<simple-statement> [ do-query ] with-disposal ;
|
||||
|
||||
: sql-command ( sql -- )
|
||||
<simple-statement> [ execute-statement ] with-disposal ;
|
||||
|
||||
SYMBOL: in-transaction
|
||||
HOOK: begin-transaction db ( -- )
|
||||
HOOK: commit-transaction db ( -- )
|
||||
HOOK: rollback-transaction db ( -- )
|
||||
|
||||
: in-transaction? ( -- ? ) in-transaction get ;
|
||||
|
||||
: with-transaction ( quot -- )
|
||||
t in-transaction [
|
||||
begin-transaction
|
||||
[ ] [ rollback-transaction ] cleanup commit-transaction
|
||||
] with-variable ;
|
||||
|
|
@ -1,12 +1,10 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
! adapted from libpq-fe.h version 7.4.7
|
||||
! tested on debian linux with postgresql 7.4.7
|
||||
! Updated to 8.1
|
||||
! tested on debian linux with postgresql 8.1
|
||||
|
||||
USING: alien alien.syntax combinators system ;
|
||||
IN: postgresql.libpq
|
||||
IN: db.postgresql.ffi
|
||||
|
||||
<<
|
||||
"postgresql" {
|
||||
|
|
@ -17,45 +15,44 @@ IN: postgresql.libpq
|
|||
>>
|
||||
|
||||
! ConnSatusType
|
||||
: CONNECTION_OK HEX: 0 ; inline
|
||||
: CONNECTION_BAD HEX: 1 ; inline
|
||||
: CONNECTION_STARTED HEX: 2 ; inline
|
||||
: CONNECTION_MADE HEX: 3 ; inline
|
||||
: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline
|
||||
: CONNECTION_AUTH_OK HEX: 5 ; inline
|
||||
: CONNECTION_SETENV HEX: 6 ; inline
|
||||
: CONNECTION_SSL_STARTUP HEX: 7 ; inline
|
||||
: CONNECTION_NEEDED HEX: 8 ; inline
|
||||
: CONNECTION_OK HEX: 0 ; inline
|
||||
: CONNECTION_BAD HEX: 1 ; inline
|
||||
: CONNECTION_STARTED HEX: 2 ; inline
|
||||
: CONNECTION_MADE HEX: 3 ; inline
|
||||
: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline
|
||||
: CONNECTION_AUTH_OK HEX: 5 ; inline
|
||||
: CONNECTION_SETENV HEX: 6 ; inline
|
||||
: CONNECTION_SSL_STARTUP HEX: 7 ; inline
|
||||
: CONNECTION_NEEDED HEX: 8 ; inline
|
||||
|
||||
! PostgresPollingStatusType
|
||||
: PGRES_POLLING_FAILED HEX: 0 ; inline
|
||||
: PGRES_POLLING_READING HEX: 1 ; inline
|
||||
: PGRES_POLLING_WRITING HEX: 2 ; inline
|
||||
: PGRES_POLLING_OK HEX: 3 ; inline
|
||||
: PGRES_POLLING_ACTIVE HEX: 4 ; inline
|
||||
: PGRES_POLLING_FAILED HEX: 0 ; inline
|
||||
: PGRES_POLLING_READING HEX: 1 ; inline
|
||||
: PGRES_POLLING_WRITING HEX: 2 ; inline
|
||||
: PGRES_POLLING_OK HEX: 3 ; inline
|
||||
: PGRES_POLLING_ACTIVE HEX: 4 ; inline
|
||||
|
||||
! ExecStatusType;
|
||||
: PGRES_EMPTY_QUERY HEX: 0 ; inline
|
||||
: PGRES_COMMAND_OK HEX: 1 ; inline
|
||||
: PGRES_TUPLES_OK HEX: 2 ; inline
|
||||
: PGRES_COPY_OUT HEX: 3 ; inline
|
||||
: PGRES_COPY_IN HEX: 4 ; inline
|
||||
: PGRES_BAD_RESPONSE HEX: 5 ; inline
|
||||
: PGRES_NONFATAL_ERROR HEX: 6 ; inline
|
||||
: PGRES_FATAL_ERROR HEX: 7 ; inline
|
||||
: PGRES_EMPTY_QUERY HEX: 0 ; inline
|
||||
: PGRES_COMMAND_OK HEX: 1 ; inline
|
||||
: PGRES_TUPLES_OK HEX: 2 ; inline
|
||||
: PGRES_COPY_OUT HEX: 3 ; inline
|
||||
: PGRES_COPY_IN HEX: 4 ; inline
|
||||
: PGRES_BAD_RESPONSE HEX: 5 ; inline
|
||||
: PGRES_NONFATAL_ERROR HEX: 6 ; inline
|
||||
: PGRES_FATAL_ERROR HEX: 7 ; inline
|
||||
|
||||
! PGTransactionStatusType;
|
||||
: PQTRANS_IDLE HEX: 0 ; inline
|
||||
: PQTRANS_ACTIVE HEX: 1 ; inline
|
||||
: PQTRANS_INTRANS HEX: 2 ; inline
|
||||
: PQTRANS_INERROR HEX: 3 ; inline
|
||||
: PQTRANS_UNKNOWN HEX: 4 ; inline
|
||||
: PQTRANS_IDLE HEX: 0 ; inline
|
||||
: PQTRANS_ACTIVE HEX: 1 ; inline
|
||||
: PQTRANS_INTRANS HEX: 2 ; inline
|
||||
: PQTRANS_INERROR HEX: 3 ; inline
|
||||
: PQTRANS_UNKNOWN HEX: 4 ; inline
|
||||
|
||||
! PGVerbosity;
|
||||
: PQERRORS_TERSE HEX: 0 ; inline
|
||||
: PQERRORS_DEFAULT HEX: 1 ; inline
|
||||
: PQERRORS_VERBOSE HEX: 2 ; inline
|
||||
|
||||
: PQERRORS_TERSE HEX: 0 ; inline
|
||||
: PQERRORS_DEFAULT HEX: 1 ; inline
|
||||
: PQERRORS_VERBOSE HEX: 2 ; inline
|
||||
|
||||
TYPEDEF: int size_t
|
||||
TYPEDEF: int ConnStatusType
|
||||
|
|
@ -81,7 +78,6 @@ LIBRARY: postgresql
|
|||
|
||||
|
||||
! Exported functions of libpq
|
||||
! === in fe-connect.c ===
|
||||
|
||||
! make a new client connection to the backend
|
||||
! Asynchronous (non-blocking)
|
||||
|
|
@ -91,12 +87,12 @@ FUNCTION: PostgresPollingStatusType PQconnectPoll ( PGconn* conn ) ;
|
|||
! Synchronous (blocking)
|
||||
FUNCTION: PGconn* PQconnectdb ( char* conninfo ) ;
|
||||
FUNCTION: PGconn* PQsetdbLogin ( char* pghost, char* pgport,
|
||||
char* pgoptions, char* pgtty,
|
||||
char* dbName,
|
||||
char* login, char* pwd ) ;
|
||||
char* pgoptions, char* pgtty,
|
||||
char* dbName,
|
||||
char* login, char* pwd ) ;
|
||||
|
||||
: PQsetdb ( M_PGHOST M_PGPORT M_PGOPT M_PGTTY M_DBNAME -- PGconn* )
|
||||
f f PQsetdbLogin ;
|
||||
f f PQsetdbLogin ;
|
||||
|
||||
! close the current connection and free the PGconn data structure
|
||||
FUNCTION: void PQfinish ( PGconn* conn ) ;
|
||||
|
|
@ -112,7 +108,7 @@ FUNCTION: void PQconninfoFree ( PQconninfoOption* connOptions ) ;
|
|||
! parameters
|
||||
!
|
||||
! Asynchronous (non-blocking)
|
||||
FUNCTION: int PQresetStart ( PGconn* conn ) ;
|
||||
FUNCTION: int PQresetStart ( PGconn* conn ) ;
|
||||
FUNCTION: PostgresPollingStatusType PQresetPoll ( PGconn* conn ) ;
|
||||
|
||||
! Synchronous (blocking)
|
||||
|
|
@ -125,7 +121,7 @@ FUNCTION: PGcancel* PQgetCancel ( PGconn* conn ) ;
|
|||
FUNCTION: void PQfreeCancel ( PGcancel* cancel ) ;
|
||||
|
||||
! issue a cancel request
|
||||
FUNCTION: int PQrequestCancel ( PGconn* conn ) ;
|
||||
FUNCTION: int PQrequestCancel ( PGconn* conn ) ;
|
||||
|
||||
! Accessor functions for PGconn objects
|
||||
FUNCTION: char* PQdb ( PGconn* conn ) ;
|
||||
|
|
@ -138,14 +134,14 @@ FUNCTION: char* PQoptions ( PGconn* conn ) ;
|
|||
FUNCTION: ConnStatusType PQstatus ( PGconn* conn ) ;
|
||||
FUNCTION: PGTransactionStatusType PQtransactionStatus ( PGconn* conn ) ;
|
||||
FUNCTION: char* PQparameterStatus ( PGconn* conn,
|
||||
char* paramName ) ;
|
||||
FUNCTION: int PQprotocolVersion ( PGconn* conn ) ;
|
||||
FUNCTION: int PQServerVersion ( PGconn* conn ) ;
|
||||
char* paramName ) ;
|
||||
FUNCTION: int PQprotocolVersion ( PGconn* conn ) ;
|
||||
! FUNCTION: int PQServerVersion ( PGconn* conn ) ;
|
||||
FUNCTION: char* PQerrorMessage ( PGconn* conn ) ;
|
||||
FUNCTION: int PQsocket ( PGconn* conn ) ;
|
||||
FUNCTION: int PQbackendPID ( PGconn* conn ) ;
|
||||
FUNCTION: int PQclientEncoding ( PGconn* conn ) ;
|
||||
FUNCTION: int PQsetClientEncoding ( PGconn* conn, char* encoding ) ;
|
||||
FUNCTION: int PQsocket ( PGconn* conn ) ;
|
||||
FUNCTION: int PQbackendPID ( PGconn* conn ) ;
|
||||
FUNCTION: int PQclientEncoding ( PGconn* conn ) ;
|
||||
FUNCTION: int PQsetClientEncoding ( PGconn* conn, char* encoding ) ;
|
||||
|
||||
! May not be compiled into libpq
|
||||
! Get the SSL structure associated with a connection
|
||||
|
|
@ -156,7 +152,7 @@ FUNCTION: void PQinitSSL ( int do_init ) ;
|
|||
|
||||
! Set verbosity for PQerrorMessage and PQresultErrorMessage
|
||||
FUNCTION: PGVerbosity PQsetErrorVerbosity ( PGconn* conn,
|
||||
PGVerbosity verbosity ) ;
|
||||
PGVerbosity verbosity ) ;
|
||||
|
||||
! Enable/disable tracing
|
||||
FUNCTION: void PQtrace ( PGconn* conn, FILE* debug_port ) ;
|
||||
|
|
@ -171,11 +167,11 @@ FUNCTION: void PQuntrace ( PGconn* conn ) ;
|
|||
|
||||
! Override default notice handling routines
|
||||
! FUNCTION: PQnoticeReceiver PQsetNoticeReceiver ( PGconn* conn,
|
||||
! PQnoticeReceiver proc,
|
||||
! void* arg ) ;
|
||||
! PQnoticeReceiver proc,
|
||||
! void* arg ) ;
|
||||
! FUNCTION: PQnoticeProcessor PQsetNoticeProcessor ( PGconn* conn,
|
||||
! PQnoticeProcessor proc,
|
||||
! void* arg ) ;
|
||||
! PQnoticeProcessor proc,
|
||||
! void* arg ) ;
|
||||
! END BROKEN
|
||||
|
||||
! === in fe-exec.c ===
|
||||
|
|
@ -183,83 +179,83 @@ FUNCTION: void PQuntrace ( PGconn* conn ) ;
|
|||
! Simple synchronous query
|
||||
FUNCTION: PGresult* PQexec ( PGconn* conn, char* query ) ;
|
||||
FUNCTION: PGresult* PQexecParams ( PGconn* conn,
|
||||
char* command,
|
||||
int nParams,
|
||||
Oid* paramTypes,
|
||||
char** paramValues,
|
||||
int* paramLengths,
|
||||
int* paramFormats,
|
||||
int resultFormat ) ;
|
||||
char* command,
|
||||
int nParams,
|
||||
Oid* paramTypes,
|
||||
char** paramValues,
|
||||
int* paramLengths,
|
||||
int* paramFormats,
|
||||
int resultFormat ) ;
|
||||
FUNCTION: PGresult* PQprepare ( PGconn* conn, char* stmtName,
|
||||
char* query, int nParams,
|
||||
Oid* paramTypes ) ;
|
||||
FUNCTION: PGresult* PQexecPrepared ( PGconn* conn,
|
||||
char* stmtName,
|
||||
int nParams,
|
||||
char** paramValues,
|
||||
int* paramLengths,
|
||||
int* paramFormats,
|
||||
int resultFormat ) ;
|
||||
char* stmtName,
|
||||
int nParams,
|
||||
char** paramValues,
|
||||
int* paramLengths,
|
||||
int* paramFormats,
|
||||
int resultFormat ) ;
|
||||
|
||||
! Interface for multiple-result or asynchronous queries
|
||||
FUNCTION: int PQsendQuery ( PGconn* conn, char* query ) ;
|
||||
FUNCTION: int PQsendQueryParams ( PGconn* conn,
|
||||
char* command,
|
||||
int nParams,
|
||||
Oid* paramTypes,
|
||||
char** paramValues,
|
||||
int* paramLengths,
|
||||
int* paramFormats,
|
||||
int resultFormat ) ;
|
||||
char* command,
|
||||
int nParams,
|
||||
Oid* paramTypes,
|
||||
char** paramValues,
|
||||
int* paramLengths,
|
||||
int* paramFormats,
|
||||
int resultFormat ) ;
|
||||
FUNCTION: PGresult* PQsendPrepare ( PGconn* conn, char* stmtName,
|
||||
char* query, int nParams,
|
||||
Oid* paramTypes ) ;
|
||||
FUNCTION: int PQsendQueryPrepared ( PGconn* conn,
|
||||
char* stmtName,
|
||||
int nParams,
|
||||
char** paramValues,
|
||||
int *paramLengths,
|
||||
int *paramFormats,
|
||||
int resultFormat ) ;
|
||||
char* stmtName,
|
||||
int nParams,
|
||||
char** paramValues,
|
||||
int *paramLengths,
|
||||
int *paramFormats,
|
||||
int resultFormat ) ;
|
||||
FUNCTION: PGresult* PQgetResult ( PGconn* conn ) ;
|
||||
|
||||
! Routines for managing an asynchronous query
|
||||
FUNCTION: int PQisBusy ( PGconn* conn ) ;
|
||||
FUNCTION: int PQconsumeInput ( PGconn* conn ) ;
|
||||
FUNCTION: int PQisBusy ( PGconn* conn ) ;
|
||||
FUNCTION: int PQconsumeInput ( PGconn* conn ) ;
|
||||
|
||||
! LISTEN/NOTIFY support
|
||||
FUNCTION: PGnotify* PQnotifies ( PGconn* conn ) ;
|
||||
|
||||
! Routines for copy in/out
|
||||
FUNCTION: int PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ;
|
||||
FUNCTION: int PQputCopyEnd ( PGconn* conn, char* errormsg ) ;
|
||||
FUNCTION: int PQgetCopyData ( PGconn* conn, char** buffer, int async ) ;
|
||||
FUNCTION: int PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ;
|
||||
FUNCTION: int PQputCopyEnd ( PGconn* conn, char* errormsg ) ;
|
||||
FUNCTION: int PQgetCopyData ( PGconn* conn, char** buffer, int async ) ;
|
||||
|
||||
! Deprecated routines for copy in/out
|
||||
FUNCTION: int PQgetline ( PGconn* conn, char* string, int length ) ;
|
||||
FUNCTION: int PQputline ( PGconn* conn, char* string ) ;
|
||||
FUNCTION: int PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ;
|
||||
FUNCTION: int PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ;
|
||||
FUNCTION: int PQendcopy ( PGconn* conn ) ;
|
||||
FUNCTION: int PQgetline ( PGconn* conn, char* string, int length ) ;
|
||||
FUNCTION: int PQputline ( PGconn* conn, char* string ) ;
|
||||
FUNCTION: int PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ;
|
||||
FUNCTION: int PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ;
|
||||
FUNCTION: int PQendcopy ( PGconn* conn ) ;
|
||||
|
||||
! Set blocking/nonblocking connection to the backend
|
||||
FUNCTION: int PQsetnonblocking ( PGconn* conn, int arg ) ;
|
||||
FUNCTION: int PQisnonblocking ( PGconn* conn ) ;
|
||||
FUNCTION: int PQsetnonblocking ( PGconn* conn, int arg ) ;
|
||||
FUNCTION: int PQisnonblocking ( PGconn* conn ) ;
|
||||
|
||||
! Force the write buffer to be written (or at least try)
|
||||
FUNCTION: int PQflush ( PGconn* conn ) ;
|
||||
FUNCTION: int PQflush ( PGconn* conn ) ;
|
||||
|
||||
!
|
||||
! * "Fast path" interface --- not really recommended for application
|
||||
! * use
|
||||
!
|
||||
FUNCTION: PGresult* PQfn ( PGconn* conn,
|
||||
int fnid,
|
||||
int* result_buf,
|
||||
int* result_len,
|
||||
int result_is_int,
|
||||
PQArgBlock* args,
|
||||
int nargs ) ;
|
||||
int fnid,
|
||||
int* result_buf,
|
||||
int* result_len,
|
||||
int result_is_int,
|
||||
PQArgBlock* args,
|
||||
int nargs ) ;
|
||||
|
||||
! Accessor functions for PGresult objects
|
||||
FUNCTION: ExecStatusType PQresultStatus ( PGresult* res ) ;
|
||||
|
|
@ -313,7 +309,7 @@ FUNCTION: uchar* PQunescapeBytea ( uchar* strtext,
|
|||
! These forms are deprecated!
|
||||
FUNCTION: size_t PQescapeString ( void* to, char* from, size_t length ) ;
|
||||
FUNCTION: uchar* PQescapeBytea ( uchar* bintext, size_t binlen,
|
||||
size_t* bytealen ) ;
|
||||
size_t* bytealen ) ;
|
||||
|
||||
! === in fe-print.c ===
|
||||
|
||||
|
|
@ -332,30 +328,28 @@ FUNCTION: void PQprintTuples ( PGresult* res,
|
|||
int printAttName,
|
||||
int terseOutput,
|
||||
int width ) ;
|
||||
|
||||
! === in fe-lobj.c ===
|
||||
|
||||
! Large-object access routines
|
||||
FUNCTION: int lo_open ( PGconn* conn, Oid lobjId, int mode ) ;
|
||||
FUNCTION: int lo_close ( PGconn* conn, int fd ) ;
|
||||
FUNCTION: int lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ;
|
||||
FUNCTION: int lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ;
|
||||
FUNCTION: int lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ;
|
||||
FUNCTION: Oid lo_creat ( PGconn* conn, int mode ) ;
|
||||
! FUNCTION: Oid lo_creat ( PGconn* conn, Oid lobjId ) ;
|
||||
FUNCTION: int lo_tell ( PGconn* conn, int fd ) ;
|
||||
FUNCTION: int lo_unlink ( PGconn* conn, Oid lobjId ) ;
|
||||
FUNCTION: Oid lo_import ( PGconn* conn, char* filename ) ;
|
||||
FUNCTION: int lo_export ( PGconn* conn, Oid lobjId, char* filename ) ;
|
||||
FUNCTION: int lo_open ( PGconn* conn, Oid lobjId, int mode ) ;
|
||||
FUNCTION: int lo_close ( PGconn* conn, int fd ) ;
|
||||
FUNCTION: int lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ;
|
||||
FUNCTION: int lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ;
|
||||
FUNCTION: int lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ;
|
||||
FUNCTION: Oid lo_creat ( PGconn* conn, int mode ) ;
|
||||
! FUNCTION: Oid lo_creat ( PGconn* conn, Oid lobjId ) ;
|
||||
FUNCTION: int lo_tell ( PGconn* conn, int fd ) ;
|
||||
FUNCTION: int lo_unlink ( PGconn* conn, Oid lobjId ) ;
|
||||
FUNCTION: Oid lo_import ( PGconn* conn, char* filename ) ;
|
||||
FUNCTION: int lo_export ( PGconn* conn, Oid lobjId, char* filename ) ;
|
||||
|
||||
! === in fe-misc.c ===
|
||||
|
||||
! Determine length of multibyte encoded char at *s
|
||||
FUNCTION: int PQmblen ( uchar* s, int encoding ) ;
|
||||
FUNCTION: int PQmblen ( uchar* s, int encoding ) ;
|
||||
|
||||
! Determine display length of multibyte encoded char at *s
|
||||
FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
|
||||
FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
|
||||
|
||||
! Get encoding id from environment variable PGCLIENTENCODING
|
||||
FUNCTION: int PQenv2encoding ( ) ;
|
||||
|
||||
FUNCTION: int PQenv2encoding ( ) ;
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays continuations db io kernel math namespaces
|
||||
quotations sequences db.postgresql.ffi alien alien.c-types ;
|
||||
IN: db.postgresql.lib
|
||||
|
||||
: postgresql-result-error-message ( res -- str/f )
|
||||
dup zero? [
|
||||
drop f
|
||||
] [
|
||||
PQresultErrorMessage [ CHAR: \n = ] right-trim
|
||||
] if ;
|
||||
|
||||
: postgres-result-error ( res -- )
|
||||
postgresql-result-error-message [ throw ] when* ;
|
||||
|
||||
: postgresql-error-message ( -- str )
|
||||
db get db-handle PQerrorMessage [ CHAR: \n = ] right-trim ;
|
||||
|
||||
: postgresql-error ( res -- res )
|
||||
dup [ postgresql-error-message throw ] unless ;
|
||||
|
||||
: postgresql-result-ok? ( n -- ? )
|
||||
PQresultStatus
|
||||
PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ;
|
||||
|
||||
: connect-postgres ( host port pgopts pgtty db user pass -- conn )
|
||||
PQsetdbLogin
|
||||
dup PQstatus zero? [ postgresql-error-message throw ] unless ;
|
||||
|
||||
: do-postgresql-statement ( statement -- res )
|
||||
db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [
|
||||
dup postgresql-result-error-message swap PQclear throw
|
||||
] unless ;
|
||||
|
||||
: do-postgresql-bound-statement ( statement -- res )
|
||||
>r db get db-handle r>
|
||||
[ statement-sql ] keep
|
||||
[ statement-params length f ] keep
|
||||
statement-params [ malloc-char-string ] map >c-void*-array
|
||||
f f 0 PQexecParams
|
||||
dup postgresql-result-ok? [
|
||||
dup postgresql-result-error-message swap PQclear throw
|
||||
] unless ;
|
||||
|
|
@ -0,0 +1,110 @@
|
|||
! You will need to run 'createdb factor-test' to create the database.
|
||||
! Set username and password in the 'connect' word.
|
||||
|
||||
USING: kernel db.postgresql alien continuations io prettyprint
|
||||
sequences namespaces tools.test db ;
|
||||
IN: temporary
|
||||
|
||||
IN: scratchpad
|
||||
: test-db ( -- postgresql-db )
|
||||
"localhost" "postgres" "" "factor-test" <postgresql-db> ;
|
||||
IN: temporary
|
||||
|
||||
[ ] [ test-db [ ] with-db ] unit-test
|
||||
|
||||
[ ] [
|
||||
test-db [
|
||||
[ "drop table person;" sql-command ] catch drop
|
||||
"create table person (name varchar(30), country varchar(30));"
|
||||
sql-command
|
||||
|
||||
"insert into person values('John', 'America');" sql-command
|
||||
"insert into person values('Jane', 'New Zealand');" sql-command
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
}
|
||||
] [
|
||||
test-db [
|
||||
"select * from person" sql-query
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ { "John" "America" } }
|
||||
] [
|
||||
test-db [
|
||||
"select * from person where name = $1 and country = $2"
|
||||
<simple-statement> [
|
||||
{ "Jane" "New Zealand" }
|
||||
over do-bound-query
|
||||
|
||||
{ { "Jane" "New Zealand" } } =
|
||||
[ "test fails" throw ] unless
|
||||
|
||||
{ "John" "America" }
|
||||
swap do-bound-query
|
||||
] with-disposal
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
}
|
||||
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
|
||||
[
|
||||
] [
|
||||
test-db [
|
||||
"insert into person(name, country) values('Jimmy', 'Canada')"
|
||||
sql-command
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
{ "Jimmy" "Canada" }
|
||||
}
|
||||
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
|
||||
[
|
||||
test-db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
"oops" throw
|
||||
] with-transaction
|
||||
] with-db
|
||||
] unit-test-fails
|
||||
|
||||
[ 3 ] [
|
||||
test-db [
|
||||
"select * from person" sql-query length
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
] [
|
||||
test-db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')"
|
||||
sql-command
|
||||
"insert into person(name, country) values('Jose', 'Mexico')"
|
||||
sql-command
|
||||
] with-transaction
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[ 5 ] [
|
||||
test-db [
|
||||
"select * from person" sql-query length
|
||||
] with-db
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,105 @@
|
|||
! Copyright (C) 2007, 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs alien alien.syntax continuations io
|
||||
kernel math namespaces prettyprint quotations
|
||||
sequences debugger db db.postgresql.lib db.postgresql.ffi ;
|
||||
IN: db.postgresql
|
||||
|
||||
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
|
||||
TUPLE: postgresql-statement ;
|
||||
TUPLE: postgresql-result-set ;
|
||||
: <postgresql-statement> ( statement -- postgresql-statement )
|
||||
postgresql-statement construct-delegate ;
|
||||
|
||||
: <postgresql-db> ( host user pass db -- obj )
|
||||
{
|
||||
set-postgresql-db-host
|
||||
set-postgresql-db-user
|
||||
set-postgresql-db-pass
|
||||
set-postgresql-db-db
|
||||
} postgresql-db construct ;
|
||||
|
||||
M: postgresql-db db-open ( db -- )
|
||||
dup {
|
||||
postgresql-db-host
|
||||
postgresql-db-port
|
||||
postgresql-db-pgopts
|
||||
postgresql-db-pgtty
|
||||
postgresql-db-db
|
||||
postgresql-db-user
|
||||
postgresql-db-pass
|
||||
} get-slots connect-postgres <db> swap set-delegate ;
|
||||
|
||||
M: postgresql-db dispose ( db -- )
|
||||
db-handle PQfinish ;
|
||||
|
||||
: with-postgresql ( host ust pass db quot -- )
|
||||
>r <postgresql-db> r> with-disposal ;
|
||||
|
||||
M: postgresql-statement bind-statement* ( seq statement -- )
|
||||
set-statement-params ;
|
||||
|
||||
M: postgresql-statement rebind-statement ( seq statement -- )
|
||||
bind-statement* ;
|
||||
|
||||
M: postgresql-result-set #rows ( result-set -- n )
|
||||
result-set-handle PQntuples ;
|
||||
|
||||
M: postgresql-result-set #columns ( result-set -- n )
|
||||
result-set-handle PQnfields ;
|
||||
|
||||
M: postgresql-result-set row-column ( result-set n -- obj )
|
||||
>r dup result-set-handle swap result-set-n r> PQgetvalue ;
|
||||
|
||||
M: postgresql-statement execute-statement ( statement -- )
|
||||
query-results dispose ;
|
||||
|
||||
: increment-n ( result-set -- n )
|
||||
dup result-set-n 1+ dup rot set-result-set-n ;
|
||||
|
||||
M: postgresql-statement query-results ( query -- result-set )
|
||||
dup statement-params [
|
||||
over [ bind-statement ] keep
|
||||
do-postgresql-bound-statement
|
||||
] [
|
||||
dup do-postgresql-statement
|
||||
] if*
|
||||
postgresql-result-set <result-set>
|
||||
dup init-result-set ;
|
||||
|
||||
M: postgresql-result-set advance-row ( result-set -- ? )
|
||||
dup increment-n swap result-set-max >= ;
|
||||
|
||||
M: postgresql-statement dispose ( query -- )
|
||||
dup statement-handle PQclear
|
||||
f swap set-statement-handle ;
|
||||
|
||||
M: postgresql-result-set dispose ( result-set -- )
|
||||
dup result-set-handle PQclear
|
||||
0 0 f roll {
|
||||
set-result-set-n set-result-set-max set-result-set-handle
|
||||
} set-slots ;
|
||||
|
||||
M: postgresql-statement prepare-statement ( statement -- )
|
||||
[
|
||||
>r db get db-handle "" r>
|
||||
dup statement-sql swap statement-params
|
||||
length f PQprepare postgresql-error
|
||||
] keep set-statement-handle ;
|
||||
|
||||
M: postgresql-db <simple-statement> ( sql -- statement )
|
||||
{ set-statement-sql } statement construct
|
||||
<postgresql-statement> ;
|
||||
|
||||
M: postgresql-db <prepared-statement> ( sql -- statement )
|
||||
{ set-statement-sql } statement construct
|
||||
<postgresql-statement> ;
|
||||
|
||||
M: postgresql-db begin-transaction ( -- )
|
||||
"BEGIN" sql-command ;
|
||||
|
||||
M: postgresql-db commit-transaction ( -- )
|
||||
"COMMIT" sql-command ;
|
||||
|
||||
M: postgresql-db rollback-transaction ( -- )
|
||||
"ROLLBACK" sql-command ;
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
Chris Double
|
||||
Doug Coleman
|
||||
|
|
@ -0,0 +1,130 @@
|
|||
! Copyright (C) 2005 Chris Double, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
! An interface to the sqlite database. Tested against sqlite v3.1.3.
|
||||
|
||||
! Not all functions have been wrapped yet. Only those directly involving
|
||||
! executing SQL calls and obtaining results.
|
||||
|
||||
USING: alien compiler kernel math namespaces sequences strings alien.syntax
|
||||
system combinators ;
|
||||
IN: db.sqlite.ffi
|
||||
|
||||
<<
|
||||
"sqlite" {
|
||||
{ [ winnt? ] [ "sqlite3.dll" ] }
|
||||
{ [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
|
||||
{ [ unix? ] [ "libsqlite3.so" ] }
|
||||
} cond "cdecl" add-library >>
|
||||
|
||||
! Return values from sqlite functions
|
||||
: SQLITE_OK 0 ; inline ! Successful result
|
||||
: SQLITE_ERROR 1 ; inline ! SQL error or missing database
|
||||
: SQLITE_INTERNAL 2 ; inline ! An internal logic error in SQLite
|
||||
: SQLITE_PERM 3 ; inline ! Access permission denied
|
||||
: SQLITE_ABORT 4 ; inline ! Callback routine requested an abort
|
||||
: SQLITE_BUSY 5 ; inline ! The database file is locked
|
||||
: SQLITE_LOCKED 6 ; inline ! A table in the database is locked
|
||||
: SQLITE_NOMEM 7 ; inline ! A malloc() failed
|
||||
: SQLITE_READONLY 8 ; inline ! Attempt to write a readonly database
|
||||
: SQLITE_INTERRUPT 9 ; inline ! Operation terminated by sqlite_interrupt()
|
||||
: SQLITE_IOERR 10 ; inline ! Some kind of disk I/O error occurred
|
||||
: SQLITE_CORRUPT 11 ; inline ! The database disk image is malformed
|
||||
: SQLITE_NOTFOUND 12 ; inline ! (Internal Only) Table or record not found
|
||||
: SQLITE_FULL 13 ; inline ! Insertion failed because database is full
|
||||
: SQLITE_CANTOPEN 14 ; inline ! Unable to open the database file
|
||||
: SQLITE_PROTOCOL 15 ; inline ! Database lock protocol error
|
||||
: SQLITE_EMPTY 16 ; inline ! (Internal Only) Database table is empty
|
||||
: SQLITE_SCHEMA 17 ; inline ! The database schema changed
|
||||
: SQLITE_TOOBIG 18 ; inline ! Too much data for one row of a table
|
||||
: SQLITE_CONSTRAINT 19 ; inline ! Abort due to contraint violation
|
||||
: SQLITE_MISMATCH 20 ; inline ! Data type mismatch
|
||||
: SQLITE_MISUSE 21 ; inline ! Library used incorrectly
|
||||
: SQLITE_NOLFS 22 ; inline ! Uses OS features not supported on host
|
||||
: SQLITE_AUTH 23 ; inline ! Authorization denied
|
||||
: SQLITE_FORMAT 24 ; inline ! Auxiliary database format error
|
||||
: SQLITE_RANGE 25 ; inline ! 2nd parameter to sqlite3_bind out of range
|
||||
: SQLITE_NOTADB 26 ; inline ! File opened that is not a database file
|
||||
|
||||
: sqlite-error-messages ( -- seq ) {
|
||||
"Successful result"
|
||||
"SQL error or missing database"
|
||||
"An internal logic error in SQLite"
|
||||
"Access permission denied"
|
||||
"Callback routine requested an abort"
|
||||
"The database file is locked"
|
||||
"A table in the database is locked"
|
||||
"A malloc() failed"
|
||||
"Attempt to write a readonly database"
|
||||
"Operation terminated by sqlite_interrupt()"
|
||||
"Some kind of disk I/O error occurred"
|
||||
"The database disk image is malformed"
|
||||
"(Internal Only) Table or record not found"
|
||||
"Insertion failed because database is full"
|
||||
"Unable to open the database file"
|
||||
"Database lock protocol error"
|
||||
"(Internal Only) Database table is empty"
|
||||
"The database schema changed"
|
||||
"Too much data for one row of a table"
|
||||
"Abort due to contraint violation"
|
||||
"Data type mismatch"
|
||||
"Library used incorrectly"
|
||||
"Uses OS features not supported on host"
|
||||
"Authorization denied"
|
||||
"Auxiliary database format error"
|
||||
"2nd parameter to sqlite3_bind out of range"
|
||||
"File opened that is not a database file"
|
||||
} ;
|
||||
|
||||
: SQLITE_ROW 100 ; inline ! sqlite_step() has another row ready
|
||||
: SQLITE_DONE 101 ; inline ! sqlite_step() has finished executing
|
||||
|
||||
! Return values from the sqlite3_column_type function
|
||||
: SQLITE_INTEGER 1 ; inline
|
||||
: SQLITE_FLOAT 2 ; inline
|
||||
: SQLITE_TEXT 3 ; inline
|
||||
: SQLITE_BLOB 4 ; inline
|
||||
: SQLITE_NULL 5 ; inline
|
||||
|
||||
! Values for the 'destructor' parameter of the 'bind' routines.
|
||||
: SQLITE_STATIC 0 ; inline
|
||||
: SQLITE_TRANSIENT -1 ; inline
|
||||
|
||||
: SQLITE_OPEN_READONLY HEX: 00000001 ; inline
|
||||
: SQLITE_OPEN_READWRITE HEX: 00000002 ; inline
|
||||
: SQLITE_OPEN_CREATE HEX: 00000004 ; inline
|
||||
: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008 ; inline
|
||||
: SQLITE_OPEN_EXCLUSIVE HEX: 00000010 ; inline
|
||||
: SQLITE_OPEN_MAIN_DB HEX: 00000100 ; inline
|
||||
: SQLITE_OPEN_TEMP_DB HEX: 00000200 ; inline
|
||||
: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400 ; inline
|
||||
: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800 ; inline
|
||||
: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 ; inline
|
||||
: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 ; inline
|
||||
: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 ; inline
|
||||
|
||||
|
||||
TYPEDEF: void sqlite3
|
||||
TYPEDEF: void sqlite3_stmt
|
||||
|
||||
LIBRARY: sqlite
|
||||
FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
|
||||
FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
|
||||
FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
|
||||
FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
|
||||
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
|
||||
FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
|
||||
FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
|
||||
FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
|
||||
FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
|
||||
FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
|
||||
FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
|
||||
FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
|
||||
FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ;
|
||||
FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
|
||||
FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;
|
||||
|
|
@ -0,0 +1,85 @@
|
|||
! Copyright (C) 2008 Chris Double, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types assocs kernel math math.parser sequences
|
||||
db.sqlite.ffi ;
|
||||
IN: db.sqlite.lib
|
||||
|
||||
TUPLE: sqlite-error n message ;
|
||||
|
||||
: sqlite-check-result ( result -- )
|
||||
dup SQLITE_OK = [
|
||||
drop
|
||||
] [
|
||||
dup sqlite-error-messages nth
|
||||
sqlite-error construct-boa throw
|
||||
] if ;
|
||||
|
||||
: sqlite-open ( filename -- db )
|
||||
"void*" <c-object>
|
||||
[ sqlite3_open sqlite-check-result ] keep *void* ;
|
||||
|
||||
: sqlite-close ( db -- )
|
||||
sqlite3_close sqlite-check-result ;
|
||||
|
||||
: sqlite-last-insert-rowid ( db -- rowid )
|
||||
sqlite3_last_insert_rowid ;
|
||||
|
||||
: sqlite-prepare ( db sql -- statement )
|
||||
#! TODO: Support multiple statements in the SQL string.
|
||||
dup length "void*" <c-object> "void*" <c-object>
|
||||
[ sqlite3_prepare sqlite-check-result ] 2keep
|
||||
drop *void* ;
|
||||
|
||||
: sqlite-bind-text ( statement index text -- )
|
||||
dup number? [ number>string ] when
|
||||
dup length SQLITE_TRANSIENT sqlite3_bind_text sqlite-check-result ;
|
||||
|
||||
: sqlite-bind-parameter-index ( statement name -- index )
|
||||
sqlite3_bind_parameter_index ;
|
||||
|
||||
: sqlite-bind-text-by-name ( statement name text -- )
|
||||
>r dupd sqlite-bind-parameter-index r> sqlite-bind-text ;
|
||||
|
||||
: sqlite-bind-assoc ( statement assoc -- )
|
||||
swap [
|
||||
-rot sqlite-bind-text-by-name
|
||||
] curry assoc-each ;
|
||||
|
||||
: sqlite-finalize ( statement -- )
|
||||
sqlite3_finalize sqlite-check-result ;
|
||||
|
||||
: sqlite-reset ( statement -- )
|
||||
sqlite3_reset sqlite-check-result ;
|
||||
|
||||
: sqlite-#columns ( query -- int )
|
||||
sqlite3_column_count ;
|
||||
|
||||
: sqlite-column ( statement index -- string )
|
||||
sqlite3_column_text ;
|
||||
|
||||
: sqlite-row ( statement -- seq )
|
||||
dup sqlite-#columns [ sqlite-column ] with map ;
|
||||
|
||||
! 2dup sqlite3_column_type .
|
||||
! SQLITE_INTEGER 1
|
||||
! SQLITE_FLOAT 2
|
||||
! SQLITE_TEXT 3
|
||||
! SQLITE_BLOB 4
|
||||
! SQLITE_NULL 5
|
||||
|
||||
: step-complete? ( step-result -- bool )
|
||||
dup SQLITE_ROW = [
|
||||
drop f
|
||||
] [
|
||||
dup SQLITE_DONE = [ drop t ] [ sqlite-check-result t ] if
|
||||
] if ;
|
||||
|
||||
: sqlite-step ( prepared -- )
|
||||
dup sqlite3_step step-complete? [
|
||||
drop
|
||||
] [
|
||||
sqlite-step
|
||||
] if ;
|
||||
|
||||
: sqlite-next ( prepared -- ? )
|
||||
sqlite3_step step-complete? ;
|
||||
|
|
@ -0,0 +1,110 @@
|
|||
USING: io io.files io.launcher kernel namespaces
|
||||
prettyprint tools.test db.sqlite db db.sql sequences
|
||||
continuations ;
|
||||
IN: temporary
|
||||
|
||||
! "sqlite3 -init test.txt test.db"
|
||||
|
||||
IN: scratchpad
|
||||
: test.db "extra/db/sqlite/test.db" resource-path ;
|
||||
|
||||
IN: temporary
|
||||
: (create-db) ( -- str )
|
||||
[
|
||||
"sqlite3 -init " %
|
||||
test.db %
|
||||
" " %
|
||||
test.db %
|
||||
] "" make ;
|
||||
|
||||
: create-db ( -- ) (create-db) run-process drop ;
|
||||
|
||||
[ ] [ test.db delete-file ] unit-test
|
||||
|
||||
[ ] [ create-db ] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
}
|
||||
] [
|
||||
test.db [
|
||||
"select * from person" sql-query
|
||||
] with-sqlite
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ { "John" "America" } }
|
||||
] [
|
||||
test.db [
|
||||
"select * from person where name = :name and country = :country"
|
||||
<simple-statement> [
|
||||
{ { ":name" "Jane" } { ":country" "New Zealand" } }
|
||||
over do-bound-query
|
||||
|
||||
{ { "Jane" "New Zealand" } } =
|
||||
[ "test fails" throw ] unless
|
||||
|
||||
{ { ":name" "John" } { ":country" "America" } }
|
||||
swap do-bound-query
|
||||
] with-disposal
|
||||
] with-sqlite
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ "1" "John" "America" }
|
||||
{ "2" "Jane" "New Zealand" }
|
||||
}
|
||||
] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
|
||||
|
||||
[
|
||||
] [
|
||||
test.db [
|
||||
"insert into person(name, country) values('Jimmy', 'Canada')"
|
||||
sql-command
|
||||
] with-sqlite
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ "1" "John" "America" }
|
||||
{ "2" "Jane" "New Zealand" }
|
||||
{ "3" "Jimmy" "Canada" }
|
||||
}
|
||||
] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
|
||||
|
||||
[
|
||||
test.db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
"oops" throw
|
||||
] with-transaction
|
||||
] with-sqlite
|
||||
] unit-test-fails
|
||||
|
||||
[ 3 ] [
|
||||
test.db [
|
||||
"select * from person" sql-query length
|
||||
] with-sqlite
|
||||
] unit-test
|
||||
|
||||
[
|
||||
] [
|
||||
test.db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')"
|
||||
sql-command
|
||||
"insert into person(name, country) values('Jose', 'Mexico')"
|
||||
sql-command
|
||||
] with-transaction
|
||||
] with-sqlite
|
||||
] unit-test
|
||||
|
||||
[ 5 ] [
|
||||
test.db [
|
||||
"select * from person" sql-query length
|
||||
] with-sqlite
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,74 @@
|
|||
! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien arrays assocs classes compiler db db.sql
|
||||
hashtables io.files kernel math math.parser namespaces
|
||||
prettyprint sequences strings tuples alien.c-types
|
||||
continuations db.sqlite.lib db.sqlite.ffi ;
|
||||
IN: db.sqlite
|
||||
|
||||
TUPLE: sqlite-db path ;
|
||||
C: <sqlite-db> sqlite-db
|
||||
|
||||
M: sqlite-db db-open ( db -- )
|
||||
dup sqlite-db-path sqlite-open <db>
|
||||
swap set-delegate ;
|
||||
|
||||
M: sqlite-db dispose ( obj -- )
|
||||
dup db-handle sqlite-close
|
||||
f over set-db-handle
|
||||
f swap set-delegate ;
|
||||
|
||||
: with-sqlite ( path quot -- )
|
||||
>r <sqlite-db> r> with-db ; inline
|
||||
|
||||
TUPLE: sqlite-statement ;
|
||||
C: <sqlite-statement> sqlite-statement
|
||||
|
||||
TUPLE: sqlite-result-set ;
|
||||
: <sqlite-result-set> ( query -- sqlite-result-set )
|
||||
dup statement-handle sqlite-result-set <result-set> ;
|
||||
|
||||
M: sqlite-db <simple-statement> ( str -- obj )
|
||||
<prepared-statement> ;
|
||||
|
||||
M: sqlite-db <prepared-statement> ( str -- obj )
|
||||
db get db-handle over sqlite-prepare
|
||||
{ set-statement-sql set-statement-handle } statement construct
|
||||
<sqlite-statement> [ set-delegate ] keep ;
|
||||
|
||||
M: sqlite-statement dispose ( statement -- )
|
||||
statement-handle sqlite-finalize ;
|
||||
|
||||
M: sqlite-result-set dispose ( result-set -- )
|
||||
f swap set-result-set-handle ;
|
||||
|
||||
M: sqlite-statement bind-statement* ( assoc statement -- )
|
||||
statement-handle swap sqlite-bind-assoc ;
|
||||
|
||||
M: sqlite-statement rebind-statement ( assoc statement -- )
|
||||
dup statement-handle sqlite-reset
|
||||
statement-handle swap sqlite-bind-assoc ;
|
||||
|
||||
M: sqlite-statement execute-statement ( statement -- )
|
||||
statement-handle sqlite-next drop ;
|
||||
|
||||
M: sqlite-result-set #columns ( result-set -- n )
|
||||
result-set-handle sqlite-#columns ;
|
||||
|
||||
M: sqlite-result-set row-column ( result-set n -- obj )
|
||||
>r result-set-handle r> sqlite-column ;
|
||||
|
||||
M: sqlite-result-set advance-row ( result-set -- handle ? )
|
||||
result-set-handle sqlite-next ;
|
||||
|
||||
M: sqlite-statement query-results ( query -- result-set )
|
||||
dup statement-handle sqlite-result-set <result-set> ;
|
||||
|
||||
M: sqlite-db begin-transaction ( -- )
|
||||
"BEGIN" sql-command ;
|
||||
|
||||
M: sqlite-db commit-transaction ( -- )
|
||||
"COMMIT" sql-command ;
|
||||
|
||||
M: sqlite-db rollback-transaction ( -- )
|
||||
"ROLLBACK" sql-command ;
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
create table person (name varchar(30), country varchar(30));
|
||||
insert into person values('John', 'America');
|
||||
insert into person values('Jane', 'New Zealand');
|
||||
|
|
@ -27,7 +27,7 @@ M: tuple-class group-words
|
|||
swap [ slot-spec-writer ] map append ;
|
||||
|
||||
: define-consult-method ( word class quot -- )
|
||||
pick add <method> spin define-method ;
|
||||
pick add spin define-method ;
|
||||
|
||||
: define-consult ( class group quot -- )
|
||||
>r group-words r>
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs http kernel math math.parser namespaces sequences
|
||||
io io.sockets io.streams.string io.files strings splitting
|
||||
continuations ;
|
||||
continuations assocs.lib ;
|
||||
IN: http.client
|
||||
|
||||
: parse-host ( url -- host port )
|
||||
|
|
@ -44,7 +44,7 @@ DEFER: http-get-stream
|
|||
#! Should this support Location: headers that are
|
||||
#! relative URLs?
|
||||
pick 100 /i 3 = [
|
||||
dispose "Location" swap at nip http-get-stream
|
||||
dispose "location" swap peek-at nip http-get-stream
|
||||
] when ;
|
||||
|
||||
: http-get-stream ( url -- code headers stream )
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
! Copyright (C) 2003, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: hashtables io kernel math namespaces math.parser assocs
|
||||
sequences strings splitting ascii io.utf8 ;
|
||||
sequences strings splitting ascii io.utf8 assocs.lib
|
||||
namespaces unicode.case ;
|
||||
IN: http
|
||||
|
||||
: header-line ( line -- )
|
||||
": " split1 dup [ swap set ] [ 2drop ] if ;
|
||||
": " split1 dup [ swap >lower insert ] [ 2drop ] if ;
|
||||
|
||||
: (read-header) ( -- )
|
||||
readln dup
|
||||
|
|
@ -71,4 +72,3 @@ IN: http
|
|||
hash>query %
|
||||
] if
|
||||
] "" make ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs hashtables html html.elements splitting
|
||||
http io kernel math math.parser namespaces parser sequences
|
||||
strings io.server ;
|
||||
strings io.server vectors assocs.lib ;
|
||||
|
||||
IN: http.server.responders
|
||||
|
||||
|
|
@ -10,8 +10,11 @@ IN: http.server.responders
|
|||
SYMBOL: vhosts
|
||||
SYMBOL: responders
|
||||
|
||||
: >header ( value key -- multi-hash )
|
||||
H{ } clone [ insert-at ] keep ;
|
||||
|
||||
: print-header ( alist -- )
|
||||
[ swap write ": " write print ] assoc-each nl ;
|
||||
[ swap write ": " write print ] multi-assoc-each nl ;
|
||||
|
||||
: response ( msg -- ) "HTTP/1.0 " write print ;
|
||||
|
||||
|
|
@ -20,7 +23,7 @@ SYMBOL: responders
|
|||
|
||||
: error-head ( error -- )
|
||||
dup log-error response
|
||||
H{ { "Content-Type" "text/html" } } print-header nl ;
|
||||
H{ { "Content-Type" V{ "text/html" } } } print-header nl ;
|
||||
|
||||
: httpd-error ( error -- )
|
||||
#! This must be run from handle-request
|
||||
|
|
@ -36,7 +39,7 @@ SYMBOL: responders
|
|||
|
||||
: serving-content ( mime -- )
|
||||
"200 Document follows" response
|
||||
"Content-Type" associate print-header ;
|
||||
"Content-Type" >header print-header ;
|
||||
|
||||
: serving-html "text/html" serving-content ;
|
||||
|
||||
|
|
@ -46,7 +49,7 @@ SYMBOL: responders
|
|||
: serving-text "text/plain" serving-content ;
|
||||
|
||||
: redirect ( to response -- )
|
||||
response "Location" associate print-header ;
|
||||
response "Location" >header print-header ;
|
||||
|
||||
: permanent-redirect ( to -- )
|
||||
"301 Moved Permanently" redirect ;
|
||||
|
|
@ -84,14 +87,14 @@ SYMBOL: max-post-request
|
|||
: log-headers ( hash -- )
|
||||
[
|
||||
drop {
|
||||
"User-Agent"
|
||||
"Referer"
|
||||
"X-Forwarded-For"
|
||||
"Host"
|
||||
"user-agent"
|
||||
"referer"
|
||||
"x-forwarded-for"
|
||||
"host"
|
||||
} member?
|
||||
] assoc-subset [
|
||||
": " swap 3append log-message
|
||||
] assoc-each ;
|
||||
] multi-assoc-each ;
|
||||
|
||||
: prepare-url ( url -- url )
|
||||
#! This is executed in the with-request namespace.
|
||||
|
|
@ -122,7 +125,8 @@ SYMBOL: max-post-request
|
|||
|
||||
: query-param ( key -- value ) "query" get at ;
|
||||
|
||||
: header-param ( key -- value ) "header" get at ;
|
||||
: header-param ( key -- value )
|
||||
"header" get peek-at ;
|
||||
|
||||
: host ( -- string )
|
||||
#! The host the current responder was called from.
|
||||
|
|
@ -130,7 +134,7 @@ SYMBOL: max-post-request
|
|||
|
||||
: add-responder ( responder -- )
|
||||
#! Add a responder object to the list.
|
||||
"responder" over at responders get set-at ;
|
||||
"responder" over at responders get set-at ;
|
||||
|
||||
: make-responder ( quot -- )
|
||||
#! quot has stack effect ( url -- )
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ TUPLE: buffer size ptr fill pos ;
|
|||
dup buffer-ptr free f swap set-buffer-ptr ;
|
||||
|
||||
: buffer-reset ( n buffer -- )
|
||||
[ set-buffer-fill ] keep 0 swap set-buffer-pos ;
|
||||
0 swap { set-buffer-fill set-buffer-pos } set-slots ;
|
||||
|
||||
: buffer-consume ( n buffer -- )
|
||||
[ buffer-pos + ] keep
|
||||
|
|
|
|||
|
|
@ -116,6 +116,15 @@ HELP: run-detached
|
|||
"The output value can be passed to " { $link wait-for-process } " to get an exit code."
|
||||
} ;
|
||||
|
||||
HELP: kill-process
|
||||
{ $values { "process" process } }
|
||||
{ $description "Kills a running process. Does nothing if the process has already exited." } ;
|
||||
|
||||
HELP: kill-process*
|
||||
{ $values { "handle" "a process handle" } }
|
||||
{ $contract "Kills a running process." }
|
||||
{ $notes "User code should call " { $link kill-process } " intead." } ;
|
||||
|
||||
HELP: process
|
||||
{ $class-description "A class representing an active or finished process."
|
||||
$nl
|
||||
|
|
@ -137,8 +146,8 @@ HELP: with-process-stream
|
|||
{ $values
|
||||
{ "desc" "a launch descriptor" }
|
||||
{ "quot" quotation }
|
||||
{ "process" process } }
|
||||
{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". When the quotation returns, the " { $link process } " instance is output." } ;
|
||||
{ "status" "an exit code" } }
|
||||
{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". After the quotation returns, waits for the process to end and outputs the exit code." } ;
|
||||
|
||||
HELP: wait-for-process
|
||||
{ $values { "process" process } { "status" integer } }
|
||||
|
|
@ -166,6 +175,8 @@ $nl
|
|||
"The following words are used to launch processes:"
|
||||
{ $subsection run-process }
|
||||
{ $subsection run-detached }
|
||||
"Stopping processes:"
|
||||
{ $subsection kill-process }
|
||||
"Redirecting standard input and output to a pipe:"
|
||||
{ $subsection <process-stream> }
|
||||
{ $subsection with-process-stream }
|
||||
|
|
|
|||
|
|
@ -84,6 +84,11 @@ HOOK: run-process* io-backend ( desc -- handle )
|
|||
: run-detached ( desc -- process )
|
||||
>descriptor H{ { +detached+ t } } union run-process ;
|
||||
|
||||
HOOK: kill-process* io-backend ( handle -- )
|
||||
|
||||
: kill-process ( process -- )
|
||||
process-handle [ kill-process* ] when* ;
|
||||
|
||||
HOOK: process-stream* io-backend ( desc -- stream process )
|
||||
|
||||
TUPLE: process-stream process ;
|
||||
|
|
@ -93,10 +98,10 @@ TUPLE: process-stream process ;
|
|||
{ set-delegate set-process-stream-process }
|
||||
process-stream construct ;
|
||||
|
||||
: with-process-stream ( desc quot -- process )
|
||||
: with-process-stream ( desc quot -- status )
|
||||
swap <process-stream>
|
||||
[ swap with-stream ] keep
|
||||
process-stream-process ; inline
|
||||
process-stream-process wait-for-process ; inline
|
||||
|
||||
: notify-exit ( status process -- )
|
||||
[ set-process-status ] keep
|
||||
|
|
|
|||
|
|
@ -1,11 +1,39 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.backend kernel continuations ;
|
||||
USING: io.backend kernel continuations namespaces sequences
|
||||
assocs hashtables sorting arrays ;
|
||||
IN: io.monitor
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: monitor queue closed? ;
|
||||
|
||||
: check-monitor ( monitor -- )
|
||||
monitor-closed? [ "Monitor closed" throw ] when ;
|
||||
|
||||
: (monitor) ( delegate -- monitor )
|
||||
H{ } clone {
|
||||
set-delegate
|
||||
set-monitor-queue
|
||||
} monitor construct ;
|
||||
|
||||
HOOK: fill-queue io-backend ( monitor -- )
|
||||
|
||||
: changed-file ( changed path -- )
|
||||
namespace [ append ] change-at ;
|
||||
|
||||
: dequeue-change ( assoc -- path changes )
|
||||
delete-any prune natural-sort >array ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
HOOK: <monitor> io-backend ( path recursive? -- monitor )
|
||||
|
||||
HOOK: next-change io-backend ( monitor -- path changes )
|
||||
: next-change ( monitor -- path changed )
|
||||
dup check-monitor
|
||||
dup monitor-queue dup assoc-empty? [
|
||||
drop dup fill-queue next-change
|
||||
] [ nip dequeue-change ] if ;
|
||||
|
||||
SYMBOL: +add-file+
|
||||
SYMBOL: +remove-file+
|
||||
|
|
|
|||
|
|
@ -14,9 +14,9 @@ TUPLE: io-task port callbacks ;
|
|||
|
||||
: io-task-fd io-task-port port-handle ;
|
||||
|
||||
: <io-task> ( port continuation class -- task )
|
||||
>r 1vector io-task construct-boa r> construct-delegate ;
|
||||
inline
|
||||
: <io-task> ( port continuation/f class -- task )
|
||||
>r [ 1vector ] [ V{ } clone ] if* io-task construct-boa
|
||||
r> construct-delegate ; inline
|
||||
|
||||
TUPLE: input-task ;
|
||||
|
||||
|
|
@ -194,7 +194,7 @@ TUPLE: mx-port mx ;
|
|||
TUPLE: mx-task ;
|
||||
|
||||
: <mx-task> ( port -- task )
|
||||
f io-task construct-boa mx-task construct-delegate ;
|
||||
f mx-task <io-task> ;
|
||||
|
||||
M: mx-task do-io-task
|
||||
io-task-port mx-port-mx 0 swap wait-for-events f ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.backend io.nonblocking io.unix.backend io.files io
|
||||
unix kernel math continuations ;
|
||||
unix kernel math continuations math.bitfields ;
|
||||
IN: io.unix.files
|
||||
|
||||
: read-flags O_RDONLY ; inline
|
||||
|
|
@ -12,7 +12,7 @@ IN: io.unix.files
|
|||
M: unix-io <file-reader> ( path -- stream )
|
||||
open-read <reader> ;
|
||||
|
||||
: write-flags O_WRONLY O_CREAT O_TRUNC bitor bitor ; inline
|
||||
: write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline
|
||||
|
||||
: open-write ( path -- fd )
|
||||
write-flags file-mode open dup io-error ;
|
||||
|
|
@ -20,7 +20,7 @@ M: unix-io <file-reader> ( path -- stream )
|
|||
M: unix-io <file-writer> ( path -- stream )
|
||||
open-write <writer> ;
|
||||
|
||||
: append-flags O_WRONLY O_APPEND O_CREAT bitor bitor ; inline
|
||||
: append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline
|
||||
|
||||
: open-append ( path -- fd )
|
||||
append-flags file-mode open dup io-error
|
||||
|
|
|
|||
|
|
@ -57,7 +57,8 @@ MEMO: 'arguments' ( -- parser )
|
|||
: setup-redirection ( -- )
|
||||
+stdin+ get read-flags 0 redirect
|
||||
+stdout+ get write-flags 1 redirect
|
||||
+stderr+ get write-flags 2 redirect ;
|
||||
+stderr+ get dup +stdout+ eq?
|
||||
[ drop 1 2 dup2 io-error ] [ write-flags 2 redirect ] if ;
|
||||
|
||||
: spawn-process ( -- )
|
||||
[
|
||||
|
|
@ -74,6 +75,9 @@ M: unix-io run-process* ( desc -- pid )
|
|||
[ spawn-process ] [ ] with-fork <process>
|
||||
] with-descriptor ;
|
||||
|
||||
M: unix-io kill-process* ( pid -- )
|
||||
SIGTERM kill io-error ;
|
||||
|
||||
: open-pipe ( -- pair )
|
||||
2 "int" <c-array> dup pipe zero?
|
||||
[ 2 c-int-array> ] [ drop f ] if ;
|
||||
|
|
@ -107,7 +111,7 @@ M: unix-io process-stream*
|
|||
2drop t
|
||||
] [
|
||||
find-process dup [
|
||||
>r *uint r> notify-exit f
|
||||
>r *int WEXITSTATUS r> notify-exit f
|
||||
] [
|
||||
2drop f
|
||||
] if
|
||||
|
|
|
|||
|
|
@ -1,15 +1,142 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel io.backend io.monitor io.monitor.private io.files
|
||||
io.buffers io.nonblocking io.unix.backend io.unix.select
|
||||
io.unix.launcher unix.linux.inotify assocs namespaces threads
|
||||
continuations init math alien.c-types alien ;
|
||||
IN: io.unix.linux
|
||||
USING: io.backend io.unix.backend io.unix.launcher io.unix.select
|
||||
namespaces kernel assocs unix.process init ;
|
||||
|
||||
TUPLE: linux-io ;
|
||||
|
||||
INSTANCE: linux-io unix-io
|
||||
|
||||
TUPLE: linux-monitor path wd callback ;
|
||||
|
||||
: <linux-monitor> ( path wd -- monitor )
|
||||
f (monitor) {
|
||||
set-linux-monitor-path
|
||||
set-linux-monitor-wd
|
||||
set-delegate
|
||||
} linux-monitor construct ;
|
||||
|
||||
TUPLE: inotify watches ;
|
||||
|
||||
: watches ( -- assoc ) inotify get-global inotify-watches ;
|
||||
|
||||
: wd>monitor ( wd -- monitor ) watches at ;
|
||||
|
||||
: wd>path ( wd -- path ) wd>monitor linux-monitor-path ;
|
||||
|
||||
: <inotify> ( -- port )
|
||||
H{ } clone
|
||||
inotify_init dup io-error inotify <buffered-port>
|
||||
{ set-inotify-watches set-delegate } inotify construct ;
|
||||
|
||||
: inotify-fd inotify get-global port-handle ;
|
||||
|
||||
: (add-watch) ( path mask -- wd )
|
||||
inotify-fd -rot inotify_add_watch dup io-error ;
|
||||
|
||||
: check-existing ( wd -- )
|
||||
watches key? [
|
||||
"Cannot open multiple monitors for the same file" throw
|
||||
] when ;
|
||||
|
||||
: add-watch ( path mask -- monitor )
|
||||
dupd (add-watch)
|
||||
dup check-existing
|
||||
[ <linux-monitor> dup ] keep watches set-at ;
|
||||
|
||||
: remove-watch ( monitor -- )
|
||||
dup linux-monitor-wd watches delete-at
|
||||
linux-monitor-wd inotify-fd swap inotify_rm_watch io-error ;
|
||||
|
||||
M: linux-io <monitor> ( path recursive? -- monitor )
|
||||
drop IN_CHANGE_EVENTS add-watch ;
|
||||
|
||||
: notify-callback ( monitor -- )
|
||||
dup linux-monitor-callback
|
||||
f rot set-linux-monitor-callback
|
||||
[ schedule-thread ] when* ;
|
||||
|
||||
M: linux-io fill-queue ( monitor -- )
|
||||
dup linux-monitor-callback [
|
||||
"Cannot wait for changes on the same file from multiple threads" throw
|
||||
] when
|
||||
[ swap set-linux-monitor-callback stop ] callcc0
|
||||
check-monitor ;
|
||||
|
||||
M: linux-monitor dispose ( monitor -- )
|
||||
dup check-monitor
|
||||
t over set-monitor-closed?
|
||||
dup notify-callback
|
||||
remove-watch ;
|
||||
|
||||
: ?flag ( n mask symbol -- n )
|
||||
pick rot bitand 0 > [ , ] [ drop ] if ;
|
||||
|
||||
: parse-action ( mask -- changed )
|
||||
[
|
||||
IN_CREATE +add-file+ ?flag
|
||||
IN_DELETE +remove-file+ ?flag
|
||||
IN_DELETE_SELF +remove-file+ ?flag
|
||||
IN_MODIFY +modify-file+ ?flag
|
||||
IN_ATTRIB +modify-file+ ?flag
|
||||
IN_MOVED_FROM +rename-file+ ?flag
|
||||
IN_MOVED_TO +rename-file+ ?flag
|
||||
IN_MOVE_SELF +rename-file+ ?flag
|
||||
drop
|
||||
] { } make ;
|
||||
|
||||
: parse-file-notify ( buffer -- changed path )
|
||||
{
|
||||
inotify-event-wd
|
||||
inotify-event-name
|
||||
inotify-event-mask
|
||||
} get-slots
|
||||
parse-action -rot alien>char-string >r wd>path r> path+ ;
|
||||
|
||||
: events-exhausted? ( i buffer -- ? )
|
||||
buffer-fill >= ;
|
||||
|
||||
: inotify-event@ ( i buffer -- alien )
|
||||
buffer-ptr <displaced-alien> ;
|
||||
|
||||
: next-event ( i buffer -- i buffer )
|
||||
2dup inotify-event@
|
||||
inotify-event-len "inotify-event" heap-size +
|
||||
swap >r + r> ;
|
||||
|
||||
: parse-file-notifications ( i buffer -- )
|
||||
2dup events-exhausted? [ 2drop ] [
|
||||
2dup inotify-event@ dup inotify-event-wd wd>monitor [
|
||||
monitor-queue [
|
||||
parse-file-notify changed-file
|
||||
] bind
|
||||
] keep notify-callback
|
||||
next-event parse-file-notifications
|
||||
] if ;
|
||||
|
||||
: read-notifications ( port -- )
|
||||
dup refill drop
|
||||
0 over parse-file-notifications
|
||||
0 swap buffer-reset ;
|
||||
|
||||
TUPLE: inotify-task ;
|
||||
|
||||
: <inotify-task> ( port -- task )
|
||||
f inotify-task <input-task> ;
|
||||
|
||||
: init-inotify ( mx -- )
|
||||
<inotify>
|
||||
dup inotify set-global
|
||||
<inotify-task> swap register-io-task ;
|
||||
|
||||
M: inotify-task do-io-task ( task -- )
|
||||
io-task-port read-notifications f ;
|
||||
|
||||
M: linux-io init-io ( -- )
|
||||
<select-mx> mx set-global ;
|
||||
<select-mx> dup mx set-global init-inotify ;
|
||||
|
||||
T{ linux-io } set-io-backend
|
||||
|
||||
|
|
|
|||
|
|
@ -48,10 +48,10 @@ TUPLE: CreateProcess-args
|
|||
} get-slots CreateProcess win32-error=0/f ;
|
||||
|
||||
: escape-argument ( str -- newstr )
|
||||
[ [ dup CHAR: " = [ CHAR: \\ , ] when , ] each ] "" make ;
|
||||
CHAR: \s over member? [ "\"" swap "\"" 3append ] when ;
|
||||
|
||||
: join-arguments ( args -- cmd-line )
|
||||
" " join ;
|
||||
[ escape-argument ] map " " join ;
|
||||
|
||||
: app-name/cmd-line ( -- app-name cmd-line )
|
||||
+command+ get [
|
||||
|
|
@ -122,8 +122,7 @@ TUPLE: CreateProcess-args
|
|||
+stderr+ get
|
||||
dup +stdout+ eq? [
|
||||
drop
|
||||
CreateProcess-args-lpStartupInfo
|
||||
STARTUPINFO-hStdOutput
|
||||
CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
|
||||
] [
|
||||
GENERIC_WRITE CREATE_ALWAYS redirect
|
||||
swap inherited-stderr ?closed
|
||||
|
|
@ -162,6 +161,10 @@ M: windows-io run-process* ( desc -- handle )
|
|||
] with-descriptor
|
||||
] with-destructors ;
|
||||
|
||||
M: windows-io kill-process* ( handle -- )
|
||||
PROCESS_INFORMATION-hProcess
|
||||
255 TerminateProcess win32-error=0/f ;
|
||||
|
||||
: dispose-process ( process-information -- )
|
||||
#! From MSDN: "Handles in PROCESS_INFORMATION must be closed
|
||||
#! with CloseHandle when they are no longer needed."
|
||||
|
|
|
|||
|
|
@ -3,12 +3,10 @@
|
|||
USING: alien.c-types destructors io.windows
|
||||
io.windows.nt.backend kernel math windows windows.kernel32
|
||||
windows.types libc assocs alien namespaces continuations
|
||||
io.monitor io.nonblocking io.buffers io.files io sequences
|
||||
hashtables sorting arrays combinators ;
|
||||
io.monitor io.monitor.private io.nonblocking io.buffers io.files
|
||||
io sequences hashtables sorting arrays combinators ;
|
||||
IN: io.windows.nt.monitor
|
||||
|
||||
TUPLE: monitor path recursive? queue closed? ;
|
||||
|
||||
: open-directory ( path -- handle )
|
||||
FILE_LIST_DIRECTORY
|
||||
share-mode
|
||||
|
|
@ -22,23 +20,26 @@ TUPLE: monitor path recursive? queue closed? ;
|
|||
dup add-completion
|
||||
f <win32-file> ;
|
||||
|
||||
TUPLE: win32-monitor path recursive? ;
|
||||
|
||||
: <win32-monitor> ( path recursive? port -- monitor )
|
||||
(monitor) {
|
||||
set-win32-monitor-path
|
||||
set-win32-monitor-recursive?
|
||||
set-delegate
|
||||
} win32-monitor construct ;
|
||||
|
||||
M: windows-nt-io <monitor> ( path recursive? -- monitor )
|
||||
[
|
||||
>r dup open-directory monitor <buffered-port> r> {
|
||||
set-monitor-path
|
||||
set-delegate
|
||||
set-monitor-recursive?
|
||||
} monitor construct
|
||||
over open-directory win32-monitor <buffered-port>
|
||||
<win32-monitor>
|
||||
] with-destructors ;
|
||||
|
||||
: check-closed ( monitor -- )
|
||||
port-type closed eq? [ "Monitor closed" throw ] when ;
|
||||
|
||||
: begin-reading-changes ( monitor -- overlapped )
|
||||
dup port-handle win32-file-handle
|
||||
over buffer-ptr
|
||||
pick buffer-size
|
||||
roll monitor-recursive? 1 0 ?
|
||||
roll win32-monitor-recursive? 1 0 ?
|
||||
FILE_NOTIFY_CHANGE_ALL
|
||||
0 <uint>
|
||||
(make-overlapped)
|
||||
|
|
@ -49,6 +50,7 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
|
|||
[
|
||||
dup begin-reading-changes
|
||||
swap [ save-callback ] 2keep
|
||||
dup check-monitor ! we may have closed it...
|
||||
get-overlapped-result
|
||||
] with-port-timeout
|
||||
] with-destructors ;
|
||||
|
|
@ -63,30 +65,20 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
|
|||
{ [ t ] [ +modify-file+ ] }
|
||||
} cond nip ;
|
||||
|
||||
: changed-file ( directory buffer -- changed path )
|
||||
: parse-file-notify ( directory buffer -- changed path )
|
||||
{
|
||||
FILE_NOTIFY_INFORMATION-FileName
|
||||
FILE_NOTIFY_INFORMATION-FileNameLength
|
||||
FILE_NOTIFY_INFORMATION-Action
|
||||
} get-slots >r memory>u16-string path+ r> parse-action swap ;
|
||||
} get-slots parse-action 1array -rot
|
||||
memory>u16-string path+ ;
|
||||
|
||||
: (changed-files) ( directory buffer -- )
|
||||
2dup changed-file namespace [ swap add ] change-at
|
||||
2dup parse-file-notify changed-file
|
||||
dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero?
|
||||
[ 3drop ] [ swap <displaced-alien> (changed-files) ] if ;
|
||||
|
||||
: changed-files ( directory buffer len -- assoc )
|
||||
[ zero? [ 2drop ] [ (changed-files) ] if ] H{ } make-assoc ;
|
||||
|
||||
: fill-queue ( monitor -- )
|
||||
dup monitor-path over buffer-ptr pick read-changes
|
||||
changed-files
|
||||
M: windows-nt-io fill-queue ( monitor -- )
|
||||
dup win32-monitor-path over buffer-ptr pick read-changes
|
||||
[ zero? [ 2drop ] [ (changed-files) ] if ] H{ } make-assoc
|
||||
swap set-monitor-queue ;
|
||||
|
||||
M: windows-nt-io next-change ( monitor -- path changes )
|
||||
dup check-closed
|
||||
dup monitor-queue dup assoc-empty? [
|
||||
drop dup fill-queue next-change
|
||||
] [
|
||||
nip delete-any prune natural-sort >array
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ io.buffers io.files io.nonblocking io.sockets io.binary
|
|||
io.sockets.impl windows.errors strings io.streams.duplex kernel
|
||||
math namespaces sequences windows windows.kernel32
|
||||
windows.shell32 windows.types windows.winsock splitting
|
||||
continuations ;
|
||||
continuations math.bitfields ;
|
||||
IN: io.windows
|
||||
|
||||
TUPLE: windows-nt-io ;
|
||||
|
|
@ -31,8 +31,11 @@ M: windows-io normalize-directory ( string -- string )
|
|||
"\\" ?tail drop "\\*" append ;
|
||||
|
||||
: share-mode ( -- fixnum )
|
||||
FILE_SHARE_READ FILE_SHARE_WRITE bitor
|
||||
FILE_SHARE_DELETE bitor ; foldable
|
||||
{
|
||||
FILE_SHARE_READ
|
||||
FILE_SHARE_WRITE
|
||||
FILE_SHARE_DELETE
|
||||
} flags ; foldable
|
||||
|
||||
: default-security-attributes ( -- obj )
|
||||
"SECURITY_ATTRIBUTES" <c-object>
|
||||
|
|
|
|||
|
|
@ -1,255 +0,0 @@
|
|||
USING: arrays bunny combinators.lib continuations io io.files kernel
|
||||
math math.functions math.vectors multiline
|
||||
namespaces debugger
|
||||
opengl opengl.gl opengl-demo-support
|
||||
prettyprint
|
||||
sequences ui ui.gadgets ui.gestures ui.render ;
|
||||
IN: line-art
|
||||
|
||||
TUPLE: line-art-gadget
|
||||
model step1-program step2-program
|
||||
framebuffer color-texture normal-texture depth-texture framebuffer-dim ;
|
||||
|
||||
: <line-art-gadget> ( -- line-art-gadget )
|
||||
40.0 -5.0 0.275 <demo-gadget>
|
||||
maybe-download read-model
|
||||
{ set-delegate set-line-art-gadget-model } line-art-gadget construct ;
|
||||
|
||||
STRING: line-art-step1-vertex-shader-source
|
||||
varying vec3 normal;
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
gl_Position = ftransform();
|
||||
normal = gl_Normal;
|
||||
}
|
||||
|
||||
;
|
||||
|
||||
STRING: line-art-step1-fragment-shader-source
|
||||
varying vec3 normal;
|
||||
uniform vec4 color;
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
gl_FragData[0] = color;
|
||||
gl_FragData[1] = vec4(normal, 1);
|
||||
}
|
||||
|
||||
;
|
||||
|
||||
STRING: line-art-step2-vertex-shader-source
|
||||
varying vec2 coord;
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
gl_Position = ftransform();
|
||||
coord = (gl_Vertex * vec4(0.5) + vec4(0.5)).xy;
|
||||
}
|
||||
|
||||
;
|
||||
|
||||
STRING: line-art-step2-fragment-shader-source
|
||||
uniform sampler2D colormap, normalmap, depthmap;
|
||||
uniform vec4 line_color;
|
||||
varying vec2 coord;
|
||||
|
||||
const float DEPTH_RATIO_THRESHOLD = 1.001, NORMAL_DOT_THRESHOLD = 1.0, SAMPLE_SPREAD = 1.0/512.0;
|
||||
|
||||
bool
|
||||
is_normal_border(vec3 norm1, vec3 norm2)
|
||||
{
|
||||
return dot(norm1, norm2) < NORMAL_DOT_THRESHOLD;
|
||||
}
|
||||
|
||||
float
|
||||
depth_sample(vec2 c)
|
||||
{
|
||||
return texture2D(depthmap, c).x;
|
||||
}
|
||||
bool
|
||||
are_depths_border(vec3 depths)
|
||||
{
|
||||
return any(lessThan(depths, vec3(1.0/DEPTH_RATIO_THRESHOLD)))
|
||||
|| any(greaterThan(depths, vec3(DEPTH_RATIO_THRESHOLD)));
|
||||
}
|
||||
|
||||
vec3
|
||||
normal_sample(vec2 c)
|
||||
{
|
||||
return texture2D(normalmap, c).xyz;
|
||||
}
|
||||
|
||||
float
|
||||
min6(float a, float b, float c, float d, float e, float f)
|
||||
{
|
||||
return min(min(min(min(min(a, b), c), d), e), f);
|
||||
}
|
||||
|
||||
float
|
||||
border_factor(vec2 c)
|
||||
{
|
||||
vec2 coord1 = c + vec2(-SAMPLE_SPREAD, -SAMPLE_SPREAD),
|
||||
coord2 = c + vec2( SAMPLE_SPREAD, -SAMPLE_SPREAD),
|
||||
coord3 = c + vec2(-SAMPLE_SPREAD, SAMPLE_SPREAD),
|
||||
coord4 = c + vec2( SAMPLE_SPREAD, SAMPLE_SPREAD);
|
||||
|
||||
vec4 depths = vec4(depth_sample(coord1),
|
||||
depth_sample(coord2),
|
||||
depth_sample(coord3),
|
||||
depth_sample(coord4));
|
||||
if (depths == vec4(1, 1, 1, 1))
|
||||
return 0.0;
|
||||
|
||||
vec3 ratios1 = depths.xxx/depths.yzw, ratios2 = depths.yyz/depths.zww;
|
||||
|
||||
if (are_depths_border(ratios1) || are_depths_border(ratios2))
|
||||
return 1.0;
|
||||
|
||||
vec3 normal1 = normal_sample(coord1),
|
||||
normal2 = normal_sample(coord2),
|
||||
normal3 = normal_sample(coord3),
|
||||
normal4 = normal_sample(coord4);
|
||||
|
||||
float normal_border = 1.0 - min6(
|
||||
dot(normal1, normal2),
|
||||
dot(normal1, normal3),
|
||||
dot(normal1, normal4),
|
||||
dot(normal2, normal3),
|
||||
dot(normal2, normal4),
|
||||
dot(normal3, normal4)
|
||||
);
|
||||
|
||||
return normal_border;
|
||||
}
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
gl_FragColor = mix(texture2D(colormap, coord), line_color, border_factor(coord));
|
||||
}
|
||||
|
||||
;
|
||||
|
||||
: (line-art-step1-program) ( -- step1 )
|
||||
line-art-step1-vertex-shader-source line-art-step1-fragment-shader-source
|
||||
<simple-gl-program> ;
|
||||
: (line-art-step2-program) ( -- step2 )
|
||||
line-art-step2-vertex-shader-source line-art-step2-fragment-shader-source
|
||||
<simple-gl-program> ;
|
||||
|
||||
: (line-art-framebuffer-texture) ( dim iformat xformat -- texture )
|
||||
swapd >r >r >r
|
||||
GL_TEXTURE0 glActiveTexture
|
||||
gen-texture GL_TEXTURE_2D over glBindTexture
|
||||
GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
|
||||
GL_TEXTURE_2D 0 r> r> first2 0 r> GL_UNSIGNED_BYTE f glTexImage2D ;
|
||||
|
||||
: (line-art-color-texture) ( dim -- texture )
|
||||
GL_RGBA16F_ARB GL_RGBA (line-art-framebuffer-texture) ;
|
||||
|
||||
: (line-art-normal-texture) ( dim -- texture )
|
||||
GL_RGBA16F_ARB GL_RGBA (line-art-framebuffer-texture) ;
|
||||
|
||||
: (line-art-depth-texture) ( dim -- texture )
|
||||
GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (line-art-framebuffer-texture) ;
|
||||
|
||||
: (attach-framebuffer-texture) ( texture attachment -- )
|
||||
swap >r >r GL_FRAMEBUFFER_EXT r> GL_TEXTURE_2D r> 0 glFramebufferTexture2DEXT gl-error ;
|
||||
|
||||
: (line-art-framebuffer) ( color-texture normal-texture depth-texture -- framebuffer )
|
||||
3array gen-framebuffer dup [
|
||||
swap GL_COLOR_ATTACHMENT0_EXT
|
||||
GL_COLOR_ATTACHMENT1_EXT
|
||||
GL_DEPTH_ATTACHMENT_EXT 3array [ (attach-framebuffer-texture) ] 2each
|
||||
check-framebuffer
|
||||
] with-framebuffer ;
|
||||
|
||||
: line-art-remake-framebuffer-if-needed ( gadget -- )
|
||||
dup { rect-dim rect-dim line-art-gadget-framebuffer-dim } get-slots = [ 2drop ] [
|
||||
swap >r
|
||||
dup (line-art-color-texture) gl-error
|
||||
swap dup (line-art-normal-texture) gl-error
|
||||
swap dup (line-art-depth-texture) gl-error
|
||||
swap >r
|
||||
[ (line-art-framebuffer) ] 3keep
|
||||
r> r> { set-line-art-gadget-framebuffer
|
||||
set-line-art-gadget-color-texture
|
||||
set-line-art-gadget-normal-texture
|
||||
set-line-art-gadget-depth-texture
|
||||
set-line-art-gadget-framebuffer-dim } set-slots
|
||||
] if ;
|
||||
|
||||
M: line-art-gadget graft* ( gadget -- )
|
||||
[ "2.0" { "GL_ARB_draw_buffers"
|
||||
"GL_ARB_shader_objects"
|
||||
"GL_ARB_multitexture"
|
||||
"GL_ARB_texture_float" }
|
||||
require-gl-version-or-extensions
|
||||
{ "GL_EXT_framebuffer_object" } require-gl-extensions
|
||||
GL_CULL_FACE glEnable
|
||||
GL_DEPTH_TEST glEnable
|
||||
(line-art-step1-program) over set-line-art-gadget-step1-program
|
||||
(line-art-step2-program) swap set-line-art-gadget-step2-program
|
||||
] [ ] [ :c ] cleanup ;
|
||||
|
||||
M: line-art-gadget ungraft* ( gadget -- )
|
||||
dup line-art-gadget-framebuffer [
|
||||
{ [ line-art-gadget-step1-program [ delete-gl-program ] when* ]
|
||||
[ line-art-gadget-step2-program [ delete-gl-program ] when* ]
|
||||
[ line-art-gadget-framebuffer [ delete-framebuffer ] when* ]
|
||||
[ line-art-gadget-color-texture [ delete-texture ] when* ]
|
||||
[ line-art-gadget-normal-texture [ delete-texture ] when* ]
|
||||
[ line-art-gadget-depth-texture [ delete-texture ] when* ]
|
||||
[ f swap set-line-art-gadget-framebuffer-dim ]
|
||||
[ f swap set-line-art-gadget-framebuffer ] } call-with
|
||||
] [ drop ] if ;
|
||||
|
||||
: line-art-draw-setup ( gadget -- gadget )
|
||||
0.0 0.0 0.0 1.0 glClearColor
|
||||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
|
||||
dup demo-gadget-set-matrices
|
||||
dup line-art-remake-framebuffer-if-needed
|
||||
gl-error ;
|
||||
|
||||
: line-art-clear-framebuffer ( -- )
|
||||
GL_COLOR_ATTACHMENT0_EXT glDrawBuffer
|
||||
0.2 0.2 0.2 1.0 glClearColor
|
||||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
|
||||
GL_COLOR_ATTACHMENT1_EXT glDrawBuffer
|
||||
0.0 0.0 0.0 0.0 glClearColor
|
||||
GL_COLOR_BUFFER_BIT glClear ;
|
||||
|
||||
M: line-art-gadget draw-gadget* ( gadget -- )
|
||||
line-art-draw-setup
|
||||
dup line-art-gadget-framebuffer [
|
||||
line-art-clear-framebuffer
|
||||
{ GL_COLOR_ATTACHMENT0_EXT GL_COLOR_ATTACHMENT1_EXT } set-draw-buffers
|
||||
dup line-art-gadget-step1-program dup [
|
||||
"color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f
|
||||
0.0 -0.12 0.0 glTranslatef
|
||||
dup line-art-gadget-model first3 draw-bunny
|
||||
] with-gl-program
|
||||
] with-framebuffer
|
||||
init-matrices
|
||||
dup line-art-gadget-color-texture GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
|
||||
dup line-art-gadget-normal-texture GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit
|
||||
dup line-art-gadget-depth-texture GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit
|
||||
line-art-gadget-step2-program dup [
|
||||
{ [ "colormap" glGetUniformLocation 0 glUniform1i ]
|
||||
[ "normalmap" glGetUniformLocation 1 glUniform1i ]
|
||||
[ "depthmap" glGetUniformLocation 2 glUniform1i ]
|
||||
[ "line_color" glGetUniformLocation 0.2 0.0 0.0 1.0 glUniform4f ] } call-with
|
||||
{ -1.0 -1.0 } { 1.0 1.0 } rect-vertices
|
||||
] with-gl-program ;
|
||||
|
||||
: line-art-window ( -- )
|
||||
[ <line-art-gadget> "Line Art" open-window ] with-ui ;
|
||||
|
||||
MAIN: line-art-window
|
||||
|
|
@ -1 +0,0 @@
|
|||
Eduardo Cavazos
|
||||
|
|
@ -1,38 +0,0 @@
|
|||
|
||||
USING: kernel quotations arrays sequences sequences.private macros ;
|
||||
|
||||
IN: macros.zoo
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! MACRO: narray ( n -- quot )
|
||||
! dup [ f <array> ] curry
|
||||
! swap <reversed> [
|
||||
! [ swap [ set-nth-unsafe ] keep ] curry
|
||||
! ] map concat append ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! MACRO: map-call-with ( quots -- )
|
||||
! [ [ [ keep ] curry ] map concat ] keep length [ nip narray ] curry compose ;
|
||||
|
||||
! MACRO: map-call-with2 ( quots -- )
|
||||
! dup >r
|
||||
! [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
|
||||
! [ 2drop ] append
|
||||
! r> length [ narray ] curry append ;
|
||||
|
||||
! MACRO: map-exec-with ( words -- ) [ 1quotation ] map [ map-call-with ] curry ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! Conceptual implementation:
|
||||
|
||||
! : pcall ( seq quots -- seq ) [ call ] 2map ;
|
||||
|
||||
! MACRO: pcall ( quots -- )
|
||||
! [ [ unclip ] swap append ] map
|
||||
! [ [ r> swap add >r ] append ] map
|
||||
! concat
|
||||
! [ { } >r ] swap append ! pre
|
||||
! [ drop r> ] append ; ! post
|
||||
|
|
@ -1,2 +1,3 @@
|
|||
Slava Pestov
|
||||
Eduardo Cavazos
|
||||
Joe Groff
|
||||
|
|
|
|||
|
|
@ -0,0 +1,59 @@
|
|||
USING: help.markup help.syntax io kernel math quotations
|
||||
opengl.gl multiline assocs ;
|
||||
IN: opengl.capabilities
|
||||
|
||||
HELP: gl-version
|
||||
{ $values { "version" "The version string from the OpenGL implementation" } }
|
||||
{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ;
|
||||
|
||||
HELP: gl-vendor-version
|
||||
{ $values { "version" "The vendor-specific version information from the OpenGL implementation" } }
|
||||
{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ;
|
||||
|
||||
HELP: has-gl-version?
|
||||
{ $values { "version" "A version string" } { "?" "A boolean value" } }
|
||||
{ $description "Compares the version string returned by " { $link gl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ;
|
||||
|
||||
HELP: require-gl-version
|
||||
{ $values { "version" "A version string" } }
|
||||
{ $description "Throws an exception if " { $link has-gl-version? } " returns false for " { $snippet "version" } "." } ;
|
||||
|
||||
HELP: glsl-version
|
||||
{ $values { "version" "The GLSL version string from the OpenGL implementation" } }
|
||||
{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ;
|
||||
|
||||
HELP: glsl-vendor-version
|
||||
{ $values { "version" "The vendor-specific GLSL version information from the OpenGL implementation" } }
|
||||
{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ;
|
||||
|
||||
HELP: has-glsl-version?
|
||||
{ $values { "version" "A version string" } { "?" "A boolean value" } }
|
||||
{ $description "Compares the version string returned by " { $link glsl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ;
|
||||
|
||||
HELP: require-glsl-version
|
||||
{ $values { "version" "A version string" } }
|
||||
{ $description "Throws an exception if " { $link has-glsl-version? } " returns false for " { $snippet "version" } "." } ;
|
||||
|
||||
HELP: gl-extensions
|
||||
{ $values { "seq" "A sequence of strings naming the implementation-supported OpenGL extensions" } }
|
||||
{ $description "Wrapper for " { $snippet "GL_EXTENSIONS glGetString" } " that returns a sequence of extension names supported by the OpenGL implementation." } ;
|
||||
|
||||
HELP: has-gl-extensions?
|
||||
{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
|
||||
{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ;
|
||||
|
||||
HELP: has-gl-version-or-extensions?
|
||||
{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } }
|
||||
{ $description "Returns true if either " { $link has-gl-version? } " or " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ;
|
||||
|
||||
HELP: require-gl-extensions
|
||||
{ $values { "extensions" "A sequence of extension name strings" } }
|
||||
{ $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ;
|
||||
|
||||
HELP: require-gl-version-or-extensions
|
||||
{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } }
|
||||
{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ;
|
||||
|
||||
{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? has-gl-version-or-extensions? gl-version glsl-version gl-extensions } related-words
|
||||
|
||||
ABOUT: "gl-utilities"
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
! Copyright (C) 2008 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces sequences splitting opengl.gl
|
||||
continuations math.parser math arrays ;
|
||||
IN: opengl.capabilities
|
||||
|
||||
: (require-gl) ( thing require-quot make-error-quot -- )
|
||||
>r dupd call
|
||||
[ r> 2drop ]
|
||||
[ r> " " make throw ]
|
||||
if ; inline
|
||||
|
||||
: gl-extensions ( -- seq )
|
||||
GL_EXTENSIONS glGetString " " split ;
|
||||
: has-gl-extensions? ( extensions -- ? )
|
||||
gl-extensions swap [ over member? ] all? nip ;
|
||||
: (make-gl-extensions-error) ( required-extensions -- )
|
||||
gl-extensions swap seq-diff
|
||||
"Required OpenGL extensions not supported:\n" %
|
||||
[ " " % % "\n" % ] each ;
|
||||
: require-gl-extensions ( extensions -- )
|
||||
[ has-gl-extensions? ]
|
||||
[ (make-gl-extensions-error) ]
|
||||
(require-gl) ;
|
||||
|
||||
: version-seq ( version-string -- version-seq )
|
||||
"." split [ string>number ] map ;
|
||||
|
||||
: version<=> ( version1 version2 -- n )
|
||||
swap version-seq swap version-seq <=> ;
|
||||
|
||||
: (gl-version) ( -- version vendor )
|
||||
GL_VERSION glGetString " " split1 ;
|
||||
: gl-version ( -- version )
|
||||
(gl-version) drop ;
|
||||
: gl-vendor-version ( -- version )
|
||||
(gl-version) nip ;
|
||||
: has-gl-version? ( version -- ? )
|
||||
gl-version version<=> 0 <= ;
|
||||
: (make-gl-version-error) ( required-version -- )
|
||||
"Required OpenGL version " % % " not supported (" % gl-version % " available)" % ;
|
||||
: require-gl-version ( version -- )
|
||||
[ has-gl-version? ]
|
||||
[ (make-gl-version-error) ]
|
||||
(require-gl) ;
|
||||
|
||||
: (glsl-version) ( -- version vendor )
|
||||
GL_SHADING_LANGUAGE_VERSION glGetString " " split1 ;
|
||||
: glsl-version ( -- version )
|
||||
(glsl-version) drop ;
|
||||
: glsl-vendor-version ( -- version )
|
||||
(glsl-version) nip ;
|
||||
: has-glsl-version? ( version -- ? )
|
||||
glsl-version version<=> 0 <= ;
|
||||
: require-glsl-version ( version -- )
|
||||
[ has-glsl-version? ]
|
||||
[ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ]
|
||||
(require-gl) ;
|
||||
|
||||
: has-gl-version-or-extensions? ( version extensions -- ? )
|
||||
has-gl-extensions? swap has-gl-version? or ;
|
||||
|
||||
: require-gl-version-or-extensions ( version extensions -- )
|
||||
2array [ first2 has-gl-version-or-extensions? ] [
|
||||
dup first (make-gl-version-error) "\n" %
|
||||
second (make-gl-extensions-error) "\n" %
|
||||
] (require-gl) ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Testing for OpenGL versions and extensions
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
opengl
|
||||
bindings
|
||||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
USING: arrays combinators.lib kernel math math.functions math.vectors namespaces
|
||||
opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ;
|
||||
IN: opengl-demo-support
|
||||
IN: opengl.demo-support
|
||||
|
||||
: NEAR-PLANE 1.0 64.0 / ; inline
|
||||
: FAR-PLANE 4.0 ; inline
|
||||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
USING: help.markup help.syntax io kernel math quotations
|
||||
opengl.gl multiline assocs ;
|
||||
IN: opengl.framebuffers
|
||||
|
||||
HELP: gen-framebuffer
|
||||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ;
|
||||
|
||||
HELP: gen-renderbuffer
|
||||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ;
|
||||
|
||||
HELP: delete-framebuffer
|
||||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ;
|
||||
|
||||
HELP: delete-renderbuffer
|
||||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ;
|
||||
|
||||
{ gen-framebuffer delete-framebuffer } related-words
|
||||
{ gen-renderbuffer delete-renderbuffer } related-words
|
||||
|
||||
HELP: framebuffer-incomplete?
|
||||
{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } }
|
||||
{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ;
|
||||
|
||||
HELP: check-framebuffer
|
||||
{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ;
|
||||
|
||||
HELP: with-framebuffer
|
||||
{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } }
|
||||
{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ;
|
||||
|
||||
ABOUT: "gl-utilities"
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
! Copyright (C) 2008 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: opengl opengl.gl combinators continuations kernel
|
||||
alien.c-types ;
|
||||
IN: opengl.framebuffers
|
||||
|
||||
: gen-framebuffer ( -- id )
|
||||
[ glGenFramebuffersEXT ] (gen-gl-object) ;
|
||||
: gen-renderbuffer ( -- id )
|
||||
[ glGenRenderbuffersEXT ] (gen-gl-object) ;
|
||||
|
||||
: delete-framebuffer ( id -- )
|
||||
[ glDeleteFramebuffersEXT ] (delete-gl-object) ;
|
||||
: delete-renderbuffer ( id -- )
|
||||
[ glDeleteRenderbuffersEXT ] (delete-gl-object) ;
|
||||
|
||||
: framebuffer-incomplete? ( -- status/f )
|
||||
GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT
|
||||
dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ;
|
||||
|
||||
: framebuffer-error ( status -- * )
|
||||
{
|
||||
{ GL_FRAMEBUFFER_COMPLETE_EXT [ "framebuffer complete" ] }
|
||||
{ GL_FRAMEBUFFER_UNSUPPORTED_EXT [ "framebuffer configuration unsupported" ] }
|
||||
{ GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT [ "framebuffer incomplete (incomplete attachment)" ] }
|
||||
{ GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT [ "framebuffer incomplete (missing attachment)" ] }
|
||||
{ GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT [ "framebuffer incomplete (dimension mismatch)" ] }
|
||||
{ GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] }
|
||||
{ GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] }
|
||||
{ GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] }
|
||||
[ drop gl-error "unknown framebuffer error" ]
|
||||
} case throw ;
|
||||
|
||||
: check-framebuffer ( -- )
|
||||
framebuffer-incomplete? [ framebuffer-error ] when* ;
|
||||
|
||||
: with-framebuffer ( id quot -- )
|
||||
GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT
|
||||
[ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline
|
||||
|
||||
: framebuffer-attachment ( attachment -- id )
|
||||
GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT
|
||||
0 <uint> [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Rendering to offscreen textures using the GL_EXT_framebuffer_object extension
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
opengl
|
||||
bindings
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax io kernel math quotations
|
||||
opengl.gl ;
|
||||
opengl.gl multiline assocs vocabs.loader sequences ;
|
||||
IN: opengl
|
||||
|
||||
HELP: gl-color
|
||||
|
|
@ -57,15 +57,7 @@ HELP: gen-texture
|
|||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glGenTextures } " to handle the common case of generating a single texture ID." } ;
|
||||
|
||||
HELP: gen-framebuffer
|
||||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ;
|
||||
|
||||
HELP: gen-renderbuffer
|
||||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ;
|
||||
|
||||
HELP: gen-buffer
|
||||
HELP: gen-gl-buffer
|
||||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glGenBuffers } " to handle the common case of generating a single buffer ID." } ;
|
||||
|
||||
|
|
@ -73,33 +65,12 @@ HELP: delete-texture
|
|||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glDeleteTextures } " to handle the common case of deleting a single texture ID." } ;
|
||||
|
||||
HELP: delete-framebuffer
|
||||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ;
|
||||
|
||||
HELP: delete-renderbuffer
|
||||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ;
|
||||
|
||||
HELP: delete-buffer
|
||||
HELP: delete-gl-buffer
|
||||
{ $values { "id" integer } }
|
||||
{ $description "Wrapper for " { $link glDeleteBuffers } " to handle the common case of deleting a single buffer ID." } ;
|
||||
|
||||
{ gen-texture delete-texture } related-words
|
||||
{ gen-framebuffer delete-framebuffer } related-words
|
||||
{ gen-renderbuffer delete-renderbuffer } related-words
|
||||
{ gen-buffer delete-buffer } related-words
|
||||
|
||||
HELP: framebuffer-incomplete?
|
||||
{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } }
|
||||
{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ;
|
||||
|
||||
HELP: check-framebuffer
|
||||
{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ;
|
||||
|
||||
HELP: with-framebuffer
|
||||
{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } }
|
||||
{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ;
|
||||
{ gen-gl-buffer delete-gl-buffer } related-words
|
||||
|
||||
HELP: bind-texture-unit
|
||||
{ $values { "id" "The id of a texture object." } { "target" "The texture target (e.g., " { $snippet "GL_TEXTURE_2D" } ")" } { "unit" "The texture unit to bind (e.g., " { $snippet "GL_TEXTURE0" } ")" } }
|
||||
|
|
@ -148,160 +119,9 @@ HELP: with-translation
|
|||
{ $values { "loc" "a pair of integers" } { "quot" quotation } }
|
||||
{ $description "Calls the quotation with a translation by " { $snippet "loc" } " pixels applied to the current " { $link GL_MODELVIEW } " matrix, restoring the matrix when the quotation is done." } ;
|
||||
|
||||
HELP: gl-shader
|
||||
{ $class-description { $snippet "gl-shader" } " is a predicate class comprising values returned by OpenGL to represent shader objects. The following words are provided for creating and manipulating these objects:"
|
||||
{ $list
|
||||
{ { $link <gl-shader> } " - Compile GLSL code into a shader object" }
|
||||
{ { $link gl-shader-ok? } " - Check whether a shader object compiled successfully" }
|
||||
{ { $link check-gl-shader } " - Throw an error unless a shader object compiled successfully" }
|
||||
{ { $link gl-shader-info-log } " - Retrieve the info log of messages generated by the GLSL compiler" }
|
||||
{ { $link delete-gl-shader } " - Invalidate a shader object" }
|
||||
}
|
||||
"The derived predicate classes " { $link vertex-shader } " and " { $link fragment-shader } " are also defined for the two standard kinds of shader defined by the OpenGL specification." } ;
|
||||
|
||||
HELP: vertex-shader
|
||||
{ $class-description { $snippet "vertex-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_VERTEX_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following vertex shader-specific functions are defined:"
|
||||
{ $list
|
||||
{ { $link <vertex-shader> } " - Compile GLSL code into a vertex shader object "}
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: fragment-shader
|
||||
{ $class-description { $snippet "fragment-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_FRAGMENT_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following fragment shader-specific functions are defined:"
|
||||
{ $list
|
||||
{ { $link <fragment-shader> } " - Compile GLSL code into a fragment shader object "}
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: <gl-shader>
|
||||
{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } }
|
||||
{ $description "Tries to compile the given GLSL source into a shader object. The returned object can be checked for validity by " { $link check-gl-shader } " or " { $link gl-shader-ok? } ". Errors and warnings generated by the GLSL compiler will be collected in the info log, available from " { $link gl-shader-info-log } ".\n\nWhen the shader object is no longer needed, it should be deleted using " { $link delete-gl-shader } " or else be attached to a " { $link gl-program } " object deleted using " { $link delete-gl-program } "." } ;
|
||||
|
||||
HELP: <vertex-shader>
|
||||
{ $values { "source" "The GLSL source code to compile" } }
|
||||
{ $description "Tries to compile the given GLSL source into a vertex shader object. Equivalent to " { $snippet "GL_VERTEX_SHADER <gl-shader>" } "." } ;
|
||||
|
||||
HELP: <fragment-shader>
|
||||
{ $values { "source" "The GLSL source code to compile" } }
|
||||
{ $description "Tries to compile the given GLSL source into a fragment shader object. Equivalent to " { $snippet "GL_FRAGMENT_SHADER <gl-shader>" } "." } ;
|
||||
|
||||
HELP: gl-shader-ok?
|
||||
{ $values { "shader" "A " { $link gl-shader } " object" } }
|
||||
{ $description "Returns a boolean value indicating whether the given shader object compiled successfully. Compilation errors and warnings are available in the shader's info log, which can be gotten using " { $link gl-shader-info-log } "." } ;
|
||||
|
||||
HELP: check-gl-shader
|
||||
{ $values { "shader" "A " { $link gl-shader } " object" } }
|
||||
{ $description "Throws an error containing the " { $link gl-shader-info-log } " for the shader object if it failed to compile. Otherwise, the shader object is left on the stack." } ;
|
||||
|
||||
HELP: delete-gl-shader
|
||||
{ $values { "shader" "A " { $link gl-shader } " object" } }
|
||||
{ $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ;
|
||||
|
||||
HELP: gl-shader-info-log
|
||||
{ $values { "shader" "A " { $link gl-shader } " object" } }
|
||||
{ $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ;
|
||||
|
||||
HELP: gl-program
|
||||
{ $class-description { $snippet "gl-program" } " is a predicate class comprising values returned by OpenGL to represent proram objects. The following words are provided for creating and manipulating these objects:"
|
||||
{ $list
|
||||
{ { $link <gl-program> } ", " { $link <simple-gl-program> } " - Link a set of shaders into a GLSL program" }
|
||||
{ { $link gl-program-ok? } " - Check whether a program object linked successfully" }
|
||||
{ { $link check-gl-program } " - Throw an error unless a program object linked successfully" }
|
||||
{ { $link gl-program-info-log } " - Retrieve the info log of messages generated by the GLSL linker" }
|
||||
{ { $link gl-program-shaders } " - Retrieve the set of shader objects composing the GLSL program" }
|
||||
{ { $link delete-gl-program } " - Invalidate a program object and all its attached shaders" }
|
||||
{ { $link with-gl-program } " - Use a program object" }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: <gl-program>
|
||||
{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } }
|
||||
{ $description "Creates a new GLSL program object, attaches all the shader objects in the " { $snippet "shaders" } " sequence, and attempts to link them. The returned object can be checked for validity by " { $link check-gl-program } " or " { $link gl-program-ok? } ". Errors and warnings generated by the GLSL linker will be collected in the info log, available from " { $link gl-program-info-log } ".\n\nWhen the program object and its attached shaders are no longer needed, it should be deleted using " { $link delete-gl-program } "." } ;
|
||||
|
||||
HELP: <simple-gl-program>
|
||||
{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } }
|
||||
{ $description "Wrapper for " { $link <gl-program> } " for the simple case of compiling a single vertex shader and fragment shader and linking them into a GLSL program. Throws an exception if compiling or linking fails." } ;
|
||||
|
||||
{ <gl-program> <simple-gl-program> } related-words
|
||||
|
||||
HELP: gl-program-ok?
|
||||
{ $values { "program" "A " { $link gl-program } " object" } }
|
||||
{ $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ;
|
||||
|
||||
HELP: check-gl-program
|
||||
{ $values { "program" "A " { $link gl-program } " object" } }
|
||||
{ $description "Throws an error containing the " { $link gl-program-info-log } " for the program object if it failed to link. Otherwise, the program object is left on the stack." } ;
|
||||
|
||||
HELP: gl-program-info-log
|
||||
{ $values { "program" "A " { $link gl-program } " object" } }
|
||||
{ $description "Retrieves the info log for " { $snippet "program" } ", including any errors or warnings generated in linking the program object." } ;
|
||||
|
||||
HELP: delete-gl-program
|
||||
{ $values { "program" "A " { $link gl-program } " object" } }
|
||||
{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ;
|
||||
|
||||
HELP: with-gl-program
|
||||
{ $values { "program" "A " { $link gl-program } " object" } { "quot" "A quotation" } }
|
||||
{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } "." } ;
|
||||
|
||||
HELP: gl-version
|
||||
{ $values { "version" "The version string from the OpenGL implementation" } }
|
||||
{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ;
|
||||
|
||||
HELP: gl-vendor-version
|
||||
{ $values { "version" "The vendor-specific version information from the OpenGL implementation" } }
|
||||
{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ;
|
||||
|
||||
HELP: has-gl-version?
|
||||
{ $values { "version" "A version string" } { "?" "A boolean value" } }
|
||||
{ $description "Compares the version string returned by " { $link gl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ;
|
||||
|
||||
HELP: require-gl-version
|
||||
{ $values { "version" "A version string" } }
|
||||
{ $description "Throws an exception if " { $link has-gl-version? } " returns false for " { $snippet "version" } "." } ;
|
||||
|
||||
HELP: glsl-version
|
||||
{ $values { "version" "The GLSL version string from the OpenGL implementation" } }
|
||||
{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ;
|
||||
|
||||
HELP: glsl-vendor-version
|
||||
{ $values { "version" "The vendor-specific GLSL version information from the OpenGL implementation" } }
|
||||
{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ;
|
||||
|
||||
HELP: has-glsl-version?
|
||||
{ $values { "version" "A version string" } { "?" "A boolean value" } }
|
||||
{ $description "Compares the version string returned by " { $link glsl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ;
|
||||
|
||||
HELP: require-glsl-version
|
||||
{ $values { "version" "A version string" } }
|
||||
{ $description "Throws an exception if " { $link has-glsl-version? } " returns false for " { $snippet "version" } "." } ;
|
||||
|
||||
HELP: gl-extensions
|
||||
{ $values { "seq" "A sequence of strings naming the implementation-supported OpenGL extensions" } }
|
||||
{ $description "Wrapper for " { $snippet "GL_EXTENSIONS glGetString" } " that returns a sequence of extension names supported by the OpenGL implementation." } ;
|
||||
|
||||
HELP: has-gl-extensions?
|
||||
{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
|
||||
{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ;
|
||||
|
||||
HELP: require-gl-extensions
|
||||
{ $values { "extensions" "A sequence of extension name strings" } }
|
||||
{ $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ;
|
||||
|
||||
HELP: require-gl-version-or-extensions
|
||||
{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } }
|
||||
{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version, or a set of equivalent extensions." } ;
|
||||
|
||||
{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? gl-version glsl-version gl-extensions } related-words
|
||||
|
||||
ARTICLE: "gl-utilities" "OpenGL utility words"
|
||||
"In addition to the full OpenGL API, the " { $vocab-link "opengl" } " vocabulary includes some utility words to give OpenGL a more Factor-like feel."
|
||||
$nl
|
||||
"Checking implementation capabilities:"
|
||||
{ $subsection require-gl-version }
|
||||
{ $subsection require-gl-extensions }
|
||||
{ $subsection require-glsl-version }
|
||||
{ $subsection require-gl-version-or-extensions }
|
||||
"Wrappers:"
|
||||
{ $subsection gl-color }
|
||||
{ $subsection gl-vertex }
|
||||
|
|
@ -314,8 +134,6 @@ $nl
|
|||
{ $subsection do-attribs }
|
||||
{ $subsection do-matrix }
|
||||
{ $subsection with-translation }
|
||||
{ $subsection with-framebuffer }
|
||||
{ $subsection with-gl-program }
|
||||
{ $subsection make-dlist }
|
||||
"Rendering geometric shapes:"
|
||||
{ $subsection gl-line }
|
||||
|
|
@ -324,9 +142,6 @@ $nl
|
|||
{ $subsection gl-fill-poly }
|
||||
{ $subsection gl-poly }
|
||||
{ $subsection gl-gradient }
|
||||
"Compiling, linking, and using GLSL programs:"
|
||||
{ $subsection gl-shader }
|
||||
{ $subsection gl-program }
|
||||
;
|
||||
|
||||
ABOUT: "gl-utilities"
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Portions copyright (C) 2007 Eduardo Cavazos.
|
||||
! Portions copyright (C) 2008 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types continuations kernel libc math macros
|
||||
namespaces math.vectors math.constants math.functions
|
||||
math.parser opengl.gl opengl.glu combinators arrays sequences
|
||||
splitting words byte-arrays ;
|
||||
splitting words byte-arrays assocs combinators.lib ;
|
||||
IN: opengl
|
||||
|
||||
: coordinates [ first2 ] 2apply ;
|
||||
|
|
@ -30,6 +30,21 @@ IN: opengl
|
|||
|
||||
: do-enabled ( what quot -- )
|
||||
over glEnable dip glDisable ; inline
|
||||
: do-enabled-client-state ( what quot -- )
|
||||
over glEnableClientState dip glDisableClientState ; inline
|
||||
|
||||
: words>values ( word/value-seq -- value-seq )
|
||||
[ dup word? [ execute ] [ ] if ] map ;
|
||||
|
||||
: (all-enabled) ( seq quot -- )
|
||||
over [ glEnable ] each dip [ glDisable ] each ; inline
|
||||
: (all-enabled-client-state) ( seq quot -- )
|
||||
over [ glEnableClientState ] each dip [ glDisableClientState ] each ; inline
|
||||
|
||||
MACRO: all-enabled ( seq quot -- )
|
||||
>r words>values r> [ (all-enabled) ] 2curry ;
|
||||
MACRO: all-enabled-client-state ( seq quot -- )
|
||||
>r words>values r> [ (all-enabled-client-state) ] 2curry ;
|
||||
|
||||
: do-matrix ( mode quot -- )
|
||||
swap [ glMatrixMode glPushMatrix call ] keep
|
||||
|
|
@ -99,58 +114,41 @@ IN: opengl
|
|||
>r 1 0 <uint> r> keep *uint ; inline
|
||||
: gen-texture ( -- id )
|
||||
[ glGenTextures ] (gen-gl-object) ;
|
||||
: gen-framebuffer ( -- id )
|
||||
[ glGenFramebuffersEXT ] (gen-gl-object) ;
|
||||
: gen-renderbuffer ( -- id )
|
||||
[ glGenRenderbuffersEXT ] (gen-gl-object) ;
|
||||
: gen-buffer ( -- id )
|
||||
: gen-gl-buffer ( -- id )
|
||||
[ glGenBuffers ] (gen-gl-object) ;
|
||||
|
||||
: (delete-gl-object) ( id quot -- )
|
||||
>r 1 swap <uint> r> call ; inline
|
||||
: delete-texture ( id -- )
|
||||
[ glDeleteTextures ] (delete-gl-object) ;
|
||||
: delete-framebuffer ( id -- )
|
||||
[ glDeleteFramebuffersEXT ] (delete-gl-object) ;
|
||||
: delete-renderbuffer ( id -- )
|
||||
[ glDeleteRenderbuffersEXT ] (delete-gl-object) ;
|
||||
: delete-buffer ( id -- )
|
||||
: delete-gl-buffer ( id -- )
|
||||
[ glDeleteBuffers ] (delete-gl-object) ;
|
||||
|
||||
: framebuffer-incomplete? ( -- status/f )
|
||||
GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT
|
||||
dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ;
|
||||
: with-gl-buffer ( binding id quot -- )
|
||||
-rot dupd glBindBuffer
|
||||
[ slip ] [ 0 glBindBuffer ] [ ] cleanup ; inline
|
||||
|
||||
: framebuffer-error ( status -- * )
|
||||
{ { GL_FRAMEBUFFER_COMPLETE_EXT [ "framebuffer complete" ] }
|
||||
{ GL_FRAMEBUFFER_UNSUPPORTED_EXT [ "framebuffer configuration unsupported" ] }
|
||||
{ GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT [ "framebuffer incomplete (incomplete attachment)" ] }
|
||||
{ GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT [ "framebuffer incomplete (missing attachment)" ] }
|
||||
{ GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT [ "framebuffer incomplete (dimension mismatch)" ] }
|
||||
{ GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] }
|
||||
{ GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] }
|
||||
{ GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] }
|
||||
[ drop gl-error "unknown framebuffer error" ] } case throw ;
|
||||
: with-array-element-buffers ( array-buffer element-buffer quot -- )
|
||||
-rot GL_ELEMENT_ARRAY_BUFFER swap [
|
||||
swap GL_ARRAY_BUFFER -rot with-gl-buffer
|
||||
] with-gl-buffer ; inline
|
||||
|
||||
: check-framebuffer ( -- )
|
||||
framebuffer-incomplete? [ framebuffer-error ] when* ;
|
||||
: <gl-buffer> ( target data hint -- id )
|
||||
pick gen-gl-buffer [ [
|
||||
>r dup byte-length swap r> glBufferData
|
||||
] with-gl-buffer ] keep ;
|
||||
|
||||
: with-framebuffer ( id quot -- )
|
||||
GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT
|
||||
[ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline
|
||||
: buffer-offset ( int -- alien )
|
||||
<alien> ; inline
|
||||
|
||||
: bind-texture-unit ( id target unit -- )
|
||||
glActiveTexture swap glBindTexture gl-error ;
|
||||
|
||||
: framebuffer-attachment ( attachment -- id )
|
||||
GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT
|
||||
0 <uint> [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ;
|
||||
|
||||
: (set-draw-buffers) ( buffers -- )
|
||||
dup length swap >c-uint-array glDrawBuffers ;
|
||||
|
||||
MACRO: set-draw-buffers ( buffers -- )
|
||||
[ dup word? [ execute ] [ ] if ] map [ (set-draw-buffers) ] curry ;
|
||||
words>values [ (set-draw-buffers) ] curry ;
|
||||
|
||||
: do-attribs ( bits quot -- )
|
||||
swap glPushAttrib call glPopAttrib ; inline
|
||||
|
|
@ -233,7 +231,8 @@ TUPLE: sprite loc dim dim2 dlist texture ;
|
|||
dup sprite-dlist delete-dlist
|
||||
sprite-texture delete-texture ;
|
||||
|
||||
: free-sprites ( sprites -- ) [ [ free-sprite ] when* ] each ;
|
||||
: free-sprites ( sprites -- )
|
||||
[ nip [ free-sprite ] when* ] assoc-each ;
|
||||
|
||||
: with-translation ( loc quot -- )
|
||||
GL_MODELVIEW [ >r gl-translate r> call ] do-matrix ; inline
|
||||
|
|
@ -249,178 +248,3 @@ TUPLE: sprite loc dim dim2 dlist texture ;
|
|||
glLoadIdentity
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity ;
|
||||
|
||||
! Shaders
|
||||
|
||||
: c-true? ( int -- ? ) zero? not ; inline
|
||||
|
||||
: with-gl-shader-source-ptr ( string quot -- )
|
||||
swap >byte-array malloc-byte-array [
|
||||
<void*> swap call
|
||||
] keep free ; inline
|
||||
|
||||
: <gl-shader> ( source kind -- shader )
|
||||
glCreateShader dup rot
|
||||
[ 1 swap f glShaderSource ] with-gl-shader-source-ptr
|
||||
[ glCompileShader ] keep
|
||||
gl-error ;
|
||||
|
||||
: (gl-shader?) ( object -- ? )
|
||||
dup integer? [ glIsShader c-true? ] [ drop f ] if ;
|
||||
|
||||
: gl-shader-get-int ( shader enum -- value )
|
||||
0 <int> [ glGetShaderiv ] keep *int ;
|
||||
|
||||
: gl-shader-ok? ( shader -- ? )
|
||||
GL_COMPILE_STATUS gl-shader-get-int c-true? ;
|
||||
|
||||
: <vertex-shader> ( source -- vertex-shader )
|
||||
GL_VERTEX_SHADER <gl-shader> ; inline
|
||||
|
||||
: (vertex-shader?) ( object -- ? )
|
||||
dup (gl-shader?)
|
||||
[ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ]
|
||||
[ drop f ] if ;
|
||||
|
||||
: <fragment-shader> ( source -- fragment-shader )
|
||||
GL_FRAGMENT_SHADER <gl-shader> ; inline
|
||||
|
||||
: (fragment-shader?) ( object -- ? )
|
||||
dup (gl-shader?)
|
||||
[ GL_SHADER_TYPE gl-shader-get-int GL_FRAGMENT_SHADER = ]
|
||||
[ drop f ] if ;
|
||||
|
||||
: gl-shader-info-log-length ( shader -- log-length )
|
||||
GL_INFO_LOG_LENGTH gl-shader-get-int ; inline
|
||||
|
||||
: gl-shader-info-log ( shader -- log )
|
||||
dup gl-shader-info-log-length
|
||||
dup [
|
||||
0 <int> over glGetShaderInfoLog
|
||||
alien>char-string
|
||||
] with-malloc ;
|
||||
|
||||
: check-gl-shader ( shader -- shader* )
|
||||
dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ;
|
||||
|
||||
: delete-gl-shader ( shader -- ) glDeleteShader ; inline
|
||||
|
||||
PREDICATE: integer gl-shader (gl-shader?) ;
|
||||
PREDICATE: gl-shader vertex-shader (vertex-shader?) ;
|
||||
PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
|
||||
|
||||
! Programs
|
||||
|
||||
: <gl-program> ( shaders -- program )
|
||||
glCreateProgram swap
|
||||
[ dupd glAttachShader ] each
|
||||
[ glLinkProgram ] keep
|
||||
gl-error ;
|
||||
|
||||
: (gl-program?) ( object -- ? )
|
||||
dup integer? [ glIsProgram c-true? ] [ drop f ] if ;
|
||||
|
||||
: gl-program-get-int ( program enum -- value )
|
||||
0 <int> [ glGetProgramiv ] keep *int ;
|
||||
|
||||
: gl-program-ok? ( program -- ? )
|
||||
GL_LINK_STATUS gl-program-get-int c-true? ;
|
||||
|
||||
: gl-program-info-log-length ( program -- log-length )
|
||||
GL_INFO_LOG_LENGTH gl-program-get-int ; inline
|
||||
|
||||
: gl-program-info-log ( program -- log )
|
||||
dup gl-program-info-log-length
|
||||
dup [ [ 0 <int> swap glGetProgramInfoLog ] keep
|
||||
alien>char-string ] with-malloc ;
|
||||
|
||||
: check-gl-program ( program -- program* )
|
||||
dup gl-program-ok? [ dup gl-program-info-log throw ] unless ;
|
||||
|
||||
: gl-program-shaders-length ( program -- shaders-length )
|
||||
GL_ATTACHED_SHADERS gl-program-get-int ; inline
|
||||
|
||||
: gl-program-shaders ( program -- shaders )
|
||||
dup gl-program-shaders-length [
|
||||
dup "GLuint" <c-array> 0 <int> over glGetAttachedShaders
|
||||
] keep c-uint-array> ;
|
||||
|
||||
: delete-gl-program-only ( program -- )
|
||||
glDeleteProgram ; inline
|
||||
|
||||
: detach-gl-program-shader ( program shader -- )
|
||||
glDetachShader ; inline
|
||||
|
||||
: delete-gl-program ( program -- )
|
||||
dup gl-program-shaders [
|
||||
2dup detach-gl-program-shader delete-gl-shader
|
||||
] each delete-gl-program-only ;
|
||||
|
||||
: with-gl-program ( program quot -- )
|
||||
swap glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
|
||||
|
||||
PREDICATE: integer gl-program (gl-program?) ;
|
||||
|
||||
: <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program )
|
||||
>r <vertex-shader> check-gl-shader
|
||||
r> <fragment-shader> check-gl-shader
|
||||
2array <gl-program> check-gl-program ;
|
||||
|
||||
: (require-gl) ( thing require-quot make-error-quot -- )
|
||||
>r dupd call
|
||||
[ r> 2drop ]
|
||||
[ r> " " make throw ]
|
||||
if ; inline
|
||||
|
||||
: gl-extensions ( -- seq )
|
||||
GL_EXTENSIONS glGetString " " split ;
|
||||
: has-gl-extensions? ( extensions -- ? )
|
||||
gl-extensions subseq? ;
|
||||
: (make-gl-extensions-error) ( required-extensions -- )
|
||||
gl-extensions swap seq-diff
|
||||
"Required OpenGL extensions not supported:\n" %
|
||||
[ " " % % "\n" % ] each ;
|
||||
: require-gl-extensions ( extensions -- )
|
||||
[ has-gl-extensions? ]
|
||||
[ (make-gl-extensions-error) ]
|
||||
(require-gl) ;
|
||||
|
||||
: version-seq ( version-string -- version-seq )
|
||||
"." split [ string>number ] map ;
|
||||
|
||||
: version<=> ( version1 version2 -- n )
|
||||
swap version-seq swap version-seq <=> ;
|
||||
|
||||
: (gl-version) ( -- version vendor )
|
||||
GL_VERSION glGetString " " split1 ;
|
||||
: gl-version ( -- version )
|
||||
(gl-version) drop ;
|
||||
: gl-vendor-version ( -- version )
|
||||
(gl-version) nip ;
|
||||
: has-gl-version? ( version -- ? )
|
||||
gl-version version<=> 0 <= ;
|
||||
: (make-gl-version-error) ( required-version -- )
|
||||
"Required OpenGL version " % % " not supported (" % gl-version % " available)" % ;
|
||||
: require-gl-version ( version -- )
|
||||
[ has-gl-version? ]
|
||||
[ (make-gl-version-error) ]
|
||||
(require-gl) ;
|
||||
|
||||
: (glsl-version) ( -- version vendor )
|
||||
GL_SHADING_LANGUAGE_VERSION glGetString " " split1 ;
|
||||
: glsl-version ( -- version )
|
||||
(glsl-version) drop ;
|
||||
: glsl-vendor-version ( -- version )
|
||||
(glsl-version) nip ;
|
||||
: has-glsl-version? ( version -- ? )
|
||||
glsl-version version<=> 0 <= ;
|
||||
: require-glsl-version ( version -- )
|
||||
[ has-glsl-version? ]
|
||||
[ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ]
|
||||
(require-gl) ;
|
||||
|
||||
: require-gl-version-or-extensions ( version extensions -- )
|
||||
2array [ first2 has-gl-extensions? swap has-gl-version? or ]
|
||||
[ dup first (make-gl-version-error) "\n" %
|
||||
second (make-gl-extensions-error) "\n" % ]
|
||||
(require-gl) ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,112 @@
|
|||
USING: help.markup help.syntax io kernel math quotations
|
||||
opengl.gl multiline assocs ;
|
||||
IN: opengl.shaders
|
||||
|
||||
HELP: gl-shader
|
||||
{ $class-description { $snippet "gl-shader" } " is a predicate class comprising values returned by OpenGL to represent shader objects. The following words are provided for creating and manipulating these objects:"
|
||||
{ $list
|
||||
{ { $link <gl-shader> } " - Compile GLSL code into a shader object" }
|
||||
{ { $link gl-shader-ok? } " - Check whether a shader object compiled successfully" }
|
||||
{ { $link check-gl-shader } " - Throw an error unless a shader object compiled successfully" }
|
||||
{ { $link gl-shader-info-log } " - Retrieve the info log of messages generated by the GLSL compiler" }
|
||||
{ { $link delete-gl-shader } " - Invalidate a shader object" }
|
||||
}
|
||||
"The derived predicate classes " { $link vertex-shader } " and " { $link fragment-shader } " are also defined for the two standard kinds of shader defined by the OpenGL specification." } ;
|
||||
|
||||
HELP: vertex-shader
|
||||
{ $class-description { $snippet "vertex-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_VERTEX_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following vertex shader-specific functions are defined:"
|
||||
{ $list
|
||||
{ { $link <vertex-shader> } " - Compile GLSL code into a vertex shader object "}
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: fragment-shader
|
||||
{ $class-description { $snippet "fragment-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_FRAGMENT_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following fragment shader-specific functions are defined:"
|
||||
{ $list
|
||||
{ { $link <fragment-shader> } " - Compile GLSL code into a fragment shader object "}
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: <gl-shader>
|
||||
{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } }
|
||||
{ $description "Tries to compile the given GLSL source into a shader object. The returned object can be checked for validity by " { $link check-gl-shader } " or " { $link gl-shader-ok? } ". Errors and warnings generated by the GLSL compiler will be collected in the info log, available from " { $link gl-shader-info-log } ".\n\nWhen the shader object is no longer needed, it should be deleted using " { $link delete-gl-shader } " or else be attached to a " { $link gl-program } " object deleted using " { $link delete-gl-program } "." } ;
|
||||
|
||||
HELP: <vertex-shader>
|
||||
{ $values { "source" "The GLSL source code to compile" } }
|
||||
{ $description "Tries to compile the given GLSL source into a vertex shader object. Equivalent to " { $snippet "GL_VERTEX_SHADER <gl-shader>" } "." } ;
|
||||
|
||||
HELP: <fragment-shader>
|
||||
{ $values { "source" "The GLSL source code to compile" } }
|
||||
{ $description "Tries to compile the given GLSL source into a fragment shader object. Equivalent to " { $snippet "GL_FRAGMENT_SHADER <gl-shader>" } "." } ;
|
||||
|
||||
HELP: gl-shader-ok?
|
||||
{ $values { "shader" "A " { $link gl-shader } " object" } }
|
||||
{ $description "Returns a boolean value indicating whether the given shader object compiled successfully. Compilation errors and warnings are available in the shader's info log, which can be gotten using " { $link gl-shader-info-log } "." } ;
|
||||
|
||||
HELP: check-gl-shader
|
||||
{ $values { "shader" "A " { $link gl-shader } " object" } }
|
||||
{ $description "Throws an error containing the " { $link gl-shader-info-log } " for the shader object if it failed to compile. Otherwise, the shader object is left on the stack." } ;
|
||||
|
||||
HELP: delete-gl-shader
|
||||
{ $values { "shader" "A " { $link gl-shader } " object" } }
|
||||
{ $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ;
|
||||
|
||||
HELP: gl-shader-info-log
|
||||
{ $values { "shader" "A " { $link gl-shader } " object" } }
|
||||
{ $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ;
|
||||
|
||||
HELP: gl-program
|
||||
{ $class-description { $snippet "gl-program" } " is a predicate class comprising values returned by OpenGL to represent proram objects. The following words are provided for creating and manipulating these objects:"
|
||||
{ $list
|
||||
{ { $link <gl-program> } ", " { $link <simple-gl-program> } " - Link a set of shaders into a GLSL program" }
|
||||
{ { $link gl-program-ok? } " - Check whether a program object linked successfully" }
|
||||
{ { $link check-gl-program } " - Throw an error unless a program object linked successfully" }
|
||||
{ { $link gl-program-info-log } " - Retrieve the info log of messages generated by the GLSL linker" }
|
||||
{ { $link gl-program-shaders } " - Retrieve the set of shader objects composing the GLSL program" }
|
||||
{ { $link delete-gl-program } " - Invalidate a program object and all its attached shaders" }
|
||||
{ { $link with-gl-program } " - Use a program object" }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: <gl-program>
|
||||
{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } }
|
||||
{ $description "Creates a new GLSL program object, attaches all the shader objects in the " { $snippet "shaders" } " sequence, and attempts to link them. The returned object can be checked for validity by " { $link check-gl-program } " or " { $link gl-program-ok? } ". Errors and warnings generated by the GLSL linker will be collected in the info log, available from " { $link gl-program-info-log } ".\n\nWhen the program object and its attached shaders are no longer needed, it should be deleted using " { $link delete-gl-program } "." } ;
|
||||
|
||||
HELP: <simple-gl-program>
|
||||
{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } }
|
||||
{ $description "Wrapper for " { $link <gl-program> } " for the simple case of compiling a single vertex shader and fragment shader and linking them into a GLSL program. Throws an exception if compiling or linking fails." } ;
|
||||
|
||||
{ <gl-program> <simple-gl-program> } related-words
|
||||
|
||||
HELP: gl-program-ok?
|
||||
{ $values { "program" "A " { $link gl-program } " object" } }
|
||||
{ $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ;
|
||||
|
||||
HELP: check-gl-program
|
||||
{ $values { "program" "A " { $link gl-program } " object" } }
|
||||
{ $description "Throws an error containing the " { $link gl-program-info-log } " for the program object if it failed to link. Otherwise, the program object is left on the stack." } ;
|
||||
|
||||
HELP: gl-program-info-log
|
||||
{ $values { "program" "A " { $link gl-program } " object" } }
|
||||
{ $description "Retrieves the info log for " { $snippet "program" } ", including any errors or warnings generated in linking the program object." } ;
|
||||
|
||||
HELP: delete-gl-program
|
||||
{ $values { "program" "A " { $link gl-program } " object" } }
|
||||
{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ;
|
||||
|
||||
HELP: with-gl-program
|
||||
{ $values { "program" "A " { $link gl-program } " object" } { "uniforms" "An " { $link assoc } " between uniform parameter names and quotations with effect " { $snippet "( uniform-location -- )" } } { "quot" "A quotation" } }
|
||||
{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } ". Before calling " { $snippet "quot" } ", calls " { $link glGetUniformLocation } " on each key of " { $snippet "uniforms" } " to get the address of the uniform parameter, which is then placed on top of the stack as the associated quotation is called.\n\nExample:" }
|
||||
{ $code <"
|
||||
! From bunny.cel-shaded
|
||||
: (draw-cel-shaded-bunny) ( geom program -- )
|
||||
{
|
||||
{ "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] }
|
||||
{ "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] }
|
||||
{ "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] }
|
||||
{ "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] }
|
||||
{ "shininess" [ 100.0 glUniform1f ] }
|
||||
} [ bunny-geom ] with-gl-program ;
|
||||
"> } ;
|
||||
|
||||
ABOUT: "gl-utilities"
|
||||
|
|
@ -0,0 +1,134 @@
|
|||
! Copyright (C) 2008 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel opengl.gl alien.c-types continuations namespaces
|
||||
assocs alien libc opengl math sequences combinators.lib
|
||||
macros arrays ;
|
||||
IN: opengl.shaders
|
||||
|
||||
: with-gl-shader-source-ptr ( string quot -- )
|
||||
swap string>char-alien malloc-byte-array [
|
||||
<void*> swap call
|
||||
] keep free ; inline
|
||||
|
||||
: <gl-shader> ( source kind -- shader )
|
||||
glCreateShader dup rot
|
||||
[ 1 swap f glShaderSource ] with-gl-shader-source-ptr
|
||||
[ glCompileShader ] keep
|
||||
gl-error ;
|
||||
|
||||
: (gl-shader?) ( object -- ? )
|
||||
dup integer? [ glIsShader c-bool> ] [ drop f ] if ;
|
||||
|
||||
: gl-shader-get-int ( shader enum -- value )
|
||||
0 <int> [ glGetShaderiv ] keep *int ;
|
||||
|
||||
: gl-shader-ok? ( shader -- ? )
|
||||
GL_COMPILE_STATUS gl-shader-get-int c-bool> ;
|
||||
|
||||
: <vertex-shader> ( source -- vertex-shader )
|
||||
GL_VERTEX_SHADER <gl-shader> ; inline
|
||||
|
||||
: (vertex-shader?) ( object -- ? )
|
||||
dup (gl-shader?)
|
||||
[ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ]
|
||||
[ drop f ] if ;
|
||||
|
||||
: <fragment-shader> ( source -- fragment-shader )
|
||||
GL_FRAGMENT_SHADER <gl-shader> ; inline
|
||||
|
||||
: (fragment-shader?) ( object -- ? )
|
||||
dup (gl-shader?)
|
||||
[ GL_SHADER_TYPE gl-shader-get-int GL_FRAGMENT_SHADER = ]
|
||||
[ drop f ] if ;
|
||||
|
||||
: gl-shader-info-log-length ( shader -- log-length )
|
||||
GL_INFO_LOG_LENGTH gl-shader-get-int ; inline
|
||||
|
||||
: gl-shader-info-log ( shader -- log )
|
||||
dup gl-shader-info-log-length dup [
|
||||
[ 0 <int> swap glGetShaderInfoLog ] keep
|
||||
alien>char-string
|
||||
] with-malloc ;
|
||||
|
||||
: check-gl-shader ( shader -- shader* )
|
||||
dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ;
|
||||
|
||||
: delete-gl-shader ( shader -- ) glDeleteShader ; inline
|
||||
|
||||
PREDICATE: integer gl-shader (gl-shader?) ;
|
||||
PREDICATE: gl-shader vertex-shader (vertex-shader?) ;
|
||||
PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
|
||||
|
||||
! Programs
|
||||
|
||||
: <gl-program> ( shaders -- program )
|
||||
glCreateProgram swap
|
||||
[ dupd glAttachShader ] each
|
||||
[ glLinkProgram ] keep
|
||||
gl-error ;
|
||||
|
||||
: (gl-program?) ( object -- ? )
|
||||
dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;
|
||||
|
||||
: gl-program-get-int ( program enum -- value )
|
||||
0 <int> [ glGetProgramiv ] keep *int ;
|
||||
|
||||
: gl-program-ok? ( program -- ? )
|
||||
GL_LINK_STATUS gl-program-get-int c-bool> ;
|
||||
|
||||
: gl-program-info-log-length ( program -- log-length )
|
||||
GL_INFO_LOG_LENGTH gl-program-get-int ; inline
|
||||
|
||||
: gl-program-info-log ( program -- log )
|
||||
dup gl-program-info-log-length dup [
|
||||
[ 0 <int> swap glGetProgramInfoLog ] keep
|
||||
alien>char-string
|
||||
] with-malloc ;
|
||||
|
||||
: check-gl-program ( program -- program* )
|
||||
dup gl-program-ok? [ dup gl-program-info-log throw ] unless ;
|
||||
|
||||
: gl-program-shaders-length ( program -- shaders-length )
|
||||
GL_ATTACHED_SHADERS gl-program-get-int ; inline
|
||||
|
||||
: gl-program-shaders ( program -- shaders )
|
||||
dup gl-program-shaders-length [
|
||||
dup "GLuint" <c-array>
|
||||
[ 0 <int> swap glGetAttachedShaders ] keep
|
||||
] keep c-uint-array> ;
|
||||
|
||||
: delete-gl-program-only ( program -- )
|
||||
glDeleteProgram ; inline
|
||||
|
||||
: detach-gl-program-shader ( program shader -- )
|
||||
glDetachShader ; inline
|
||||
|
||||
: delete-gl-program ( program -- )
|
||||
dup gl-program-shaders [
|
||||
2dup detach-gl-program-shader delete-gl-shader
|
||||
] each delete-gl-program-only ;
|
||||
|
||||
: (with-gl-program) ( program quot -- )
|
||||
swap glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
|
||||
|
||||
: (with-gl-program-uniforms) ( uniforms -- quot )
|
||||
[ [ swap , \ glGetUniformLocation , % ] [ ] make ]
|
||||
{ } assoc>map ;
|
||||
: (make-with-gl-program) ( uniforms quot -- q )
|
||||
[
|
||||
\ dup ,
|
||||
[ swap (with-gl-program-uniforms) , \ call-with , % ]
|
||||
[ ] make ,
|
||||
\ (with-gl-program) ,
|
||||
] [ ] make ;
|
||||
|
||||
MACRO: with-gl-program ( uniforms quot -- )
|
||||
(make-with-gl-program) ;
|
||||
|
||||
PREDICATE: integer gl-program (gl-program?) ;
|
||||
|
||||
: <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program )
|
||||
>r <vertex-shader> check-gl-shader
|
||||
r> <fragment-shader> check-gl-shader
|
||||
2array <gl-program> check-gl-program ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
OpenGL Shading Language (GLSL) support
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
opengl
|
||||
glsl
|
||||
bindings
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
|
||||
USING: kernel sequences quotations math parser
|
||||
shuffle combinators.cleave combinators.lib sequences.lib ;
|
||||
|
||||
IN: partial-apply
|
||||
|
||||
! Basic conceptual implementation. Todo: get it to compile.
|
||||
|
||||
: apply-n ( obj quot i -- quot ) 1+ [ -nrot ] curry swap compose curry ;
|
||||
|
||||
SYMBOL: _
|
||||
|
||||
SYMBOL: ~
|
||||
|
||||
: blank-positions ( quot -- seq )
|
||||
[ length 2 - ] [ _ indices ] bi [ - ] map-with ;
|
||||
|
||||
: partial-apply ( pattern -- quot )
|
||||
[ blank-positions length nrev ]
|
||||
[ peek 1quotation ]
|
||||
[ blank-positions ]
|
||||
tri
|
||||
[ apply-n ] each ;
|
||||
|
||||
: $[ \ ] [ >quotation ] parse-literal \ partial-apply parsed ; parsing
|
||||
|
||||
|
|
@ -1,42 +0,0 @@
|
|||
! You will need to run 'createdb factor-test' to create the database.
|
||||
! Set username and password in the 'connect' word.
|
||||
|
||||
IN: postgresql-test
|
||||
USING: kernel postgresql alien continuations io prettyprint
|
||||
sequences namespaces ;
|
||||
|
||||
|
||||
: test-connection ( host port pgopts pgtty db user pass -- bool )
|
||||
[ [ ] with-postgres ] catch "Error connecting!" "Connected!" ? print ;
|
||||
|
||||
! just a basic demo
|
||||
|
||||
"localhost" "" "" "" "test" "postgres" "" [
|
||||
"drop table animal" do-command
|
||||
|
||||
"create table animal (id serial not null primary key, species varchar(256), name varchar(256), age integer)" do-command
|
||||
"insert into animal (species, name, age) values ('lion', 'Mufasa', 5)"
|
||||
do-command
|
||||
|
||||
"select * from animal where name = 'Mufasa'" [ ] do-query
|
||||
"select * from animal where name = 'Mufasa'"
|
||||
[
|
||||
result>seq length 1 = [ "...there can only be one Mufasa..." throw ] unless
|
||||
] do-query
|
||||
|
||||
"insert into animal (species, name, age) values ('lion', 'Simba', 1)"
|
||||
do-command
|
||||
|
||||
"select * from animal"
|
||||
[
|
||||
"Animal table:" print
|
||||
result>seq print-table
|
||||
] do-query
|
||||
|
||||
! intentional errors
|
||||
! [ "select asdf from animal"
|
||||
! [ ] do-query ] catch [ "caught: " write print ] when*
|
||||
! "select asdf from animal" [ ] do-query
|
||||
! "aofijweafew" do-command
|
||||
] with-postgres
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue