Merge branch 'master' of git://factorcode.org/git/factor into unicode

db4
Daniel Ehrenberg 2008-02-13 19:01:44 -06:00
commit e293856072
109 changed files with 8630 additions and 7419 deletions

2
.gitignore vendored
View File

@ -15,3 +15,5 @@ factor
.gdb_history
*.*.marks
.*.swp
reverse-complement-in.txt
reverse-complement-out.txt

View File

@ -167,7 +167,7 @@ DEFER: c-ushort-array>
swap dup length memcpy ;
: string>char-memory ( string base -- )
>r >byte-array r> byte-array>memory ;
>r B{ } like r> byte-array>memory ;
DEFER: >c-ushort-array

View File

@ -398,7 +398,7 @@ TUPLE: callback-context ;
callback-unwind %unwind ;
: generate-callback ( node -- )
dup alien-callback-xt dup rot [
dup alien-callback-xt dup [
init-templates
%save-word-xt
%prologue-later
@ -407,7 +407,7 @@ TUPLE: callback-context ;
dup wrap-callback-quot %alien-callback
%callback-return
] with-stack-frame
] generate-1 ;
] with-generator ;
M: alien-callback generate-node
end-basic-block generate-callback iterate-next ;

View File

@ -111,7 +111,8 @@ SYMBOL: bootstrap-time
"output-image" get resource-path save-image-and-exit
] if
] [
print-error :c restarts.
:c
print-error restarts.
"listener" vocab-main execute
1 exit
] recover

View File

@ -30,7 +30,7 @@ IN: compiler
: compile-succeeded ( word -- effect dependencies )
[
dup word-dataflow >r swap dup r> optimize generate
[ word-dataflow optimize ] keep dup generate
] computing-dependencies ;
: compile-failed ( word error -- )

View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Mackenzie Straight, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel math ;
USING: combinators kernel math sequences ;
IN: dlists
TUPLE: dlist front back length ;
@ -72,6 +72,9 @@ PRIVATE>
: push-front ( obj dlist -- )
push-front* drop ;
: push-all-front ( seq dlist -- )
[ push-front ] curry each ;
: push-back* ( obj dlist -- dlist-node )
[ dlist-back f <dlist-node> ] keep
[ dlist-back set-next-when ] 2keep
@ -80,11 +83,10 @@ PRIVATE>
inc-length ;
: push-back ( obj dlist -- )
[ dlist-back f <dlist-node> ] keep
[ dlist-back set-next-when ] 2keep
[ set-dlist-back ] keep
[ set-front-to-back ] keep
inc-length ;
push-back* drop ;
: push-all-back ( seq dlist -- )
[ push-back ] curry each ;
: peek-front ( dlist -- obj )
dlist-front dlist-node-obj ;
@ -156,3 +158,6 @@ PRIVATE>
over dlist-empty?
[ 2drop ] [ [ >r pop-back r> call ] 2keep dlist-slurp ] if ;
inline
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;

View File

@ -12,7 +12,7 @@ $nl
{ $subsection >float-vector }
{ $subsection <float-vector> }
"If you don't care about initial capacity, a more elegant way to create a new float vector is to write:"
{ $code "BV{ } clone" } ;
{ $code "FV{ } clone" } ;
ABOUT: "float-vectors"

View File

@ -140,17 +140,19 @@ SYMBOL: literal-table
V{ } clone relocation-table set
V{ } clone label-table set ;
: generate-labels ( -- labels )
label-table get [
: resolve-labels ( labels -- labels' )
[
first3 label-offset
[ "Unresolved label" throw ] unless*
3array
] map concat ;
: fixup ( code -- relocation-table label-table code )
: fixup ( code -- literals relocation labels code )
[
init-fixup
dup stack-frame-size swap [ fixup* ] each drop
literal-table get >array
relocation-table get >array
generate-labels
label-table get resolve-labels
] { } make ;

View File

@ -22,34 +22,35 @@ HELP: compiled
{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
HELP: compiling-word
{ $var-description "The word currently being compiled, set by " { $link generate-1 } "." } ;
{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ;
HELP: compiling-label
{ $var-description "The label currently being compiled, set by " { $link generate-1 } "." } ;
{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ;
HELP: compiled-stack-traces?
{ $values { "?" "a boolean" } }
{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
HELP: literal-table
{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link init-generator } " ensures that the first entry is the word being compiled." } ;
{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;
HELP: init-generator
HELP: begin-compiling
{ $values { "word" word } { "label" word } }
{ $description "Prepares to generate machine code for a word." } ;
HELP: generate-1
{ $values { "word" word } { "label" word } { "node" "a dataflow node" } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
HELP: with-generator
{ $values { "node" "a dataflow node" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the dataflow node." } ;
HELP: generate-node
{ $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
{ $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." }
{ $notes "This word can only be called from inside the quotation passed to " { $link generate-1 } "." } ;
{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
HELP: generate-nodes
{ $values { "node" "a dataflow node" } }
{ $description "Recursively generate machine code for a dataflow graph." }
{ $notes "This word can only be called from inside the quotation passed to " { $link generate-1 } "." } ;
{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
HELP: generate
{ $values { "word" word } { "label" word } { "node" "a dataflow node" } }

View File

@ -11,12 +11,6 @@ IN: generator
SYMBOL: compile-queue
SYMBOL: compiled
: begin-compiling ( word -- )
f swap compiled get set-at ;
: finish-compiling ( word literals relocation labels code -- )
4array swap compiled get set-at ;
: queue-compile ( word -- )
{
{ [ dup compiled get key? ] [ drop ] }
@ -32,24 +26,31 @@ SYMBOL: compiling-word
SYMBOL: compiling-label
SYMBOL: compiling-loop?
! Label of current word, after prologue, makes recursion faster
SYMBOL: current-label-start
: compiled-stack-traces? ( -- ? ) 36 getenv ;
: init-generator ( -- )
: begin-compiling ( word label -- )
compiling-loop? off
compiling-label set
compiling-word set
compiled-stack-traces?
compiling-word get f ?
1vector literal-table set ;
compiling-word get f ?
1vector literal-table set
f compiling-word get compiled get set-at ;
: generate-1 ( word label node quot -- )
pick begin-compiling [
roll compiling-word set
pick compiling-label set
init-generator
call
literal-table get >array
] { } make fixup finish-compiling ;
: finish-compiling ( literals relocation labels code -- )
4array compiling-label get compiled get set-at ;
: with-generator ( node word label quot -- )
[
>r begin-compiling r>
{ } make fixup
finish-compiling
] with-scope ; inline
GENERIC: generate-node ( node -- next )
@ -62,12 +63,12 @@ GENERIC: generate-node ( node -- next )
%prologue-later
current-label-start define-label
current-label-start resolve-label ;
: generate ( word label node -- )
: generate ( node word label -- )
[
init-generate-nodes
[ generate-nodes ] with-node-iterator
] generate-1 ;
] with-generator ;
: word-dataflow ( word -- effect dataflow )
[
@ -82,25 +83,6 @@ GENERIC: generate-node ( node -- next )
: if-intrinsics ( #call -- quot )
node-param "if-intrinsics" word-prop ;
DEFER: #terminal?
PREDICATE: #merge #terminal-merge node-successor #terminal? ;
PREDICATE: #values #terminal-values node-successor #terminal? ;
PREDICATE: #call #terminal-call
dup node-successor #if?
over node-successor node-successor #terminal? and
swap if-intrinsics and ;
UNION: #terminal
POSTPONE: f #return #terminal-values #terminal-merge ;
: tail-call? ( -- ? )
node-stack get [
dup #terminal-call? swap node-successor #terminal? or
] all? ;
! node
M: node generate-node drop iterate-next ;
@ -112,20 +94,38 @@ M: node generate-node drop iterate-next ;
: generate-call ( label -- next )
dup maybe-compile
end-basic-block
tail-call? [
%jump f
dup compiling-label get eq? compiling-loop? get and [
drop current-label-start get %jump-label f
] [
0 frame-required
%call
iterate-next
tail-call? [
%jump f
] [
0 frame-required
%call
iterate-next
] if
] if ;
! #label
M: #label generate-node
dup node-param generate-call >r
dup #label-word over node-param rot node-child generate
dup node-child over #label-word rot node-param generate
r> ;
! #loop
M: #loop generate-node
end-basic-block
[
dup node-param compiling-label set
current-label-start define-label
current-label-start resolve-label
compiling-loop? on
node-child generate-nodes
end-basic-block
] with-scope
init-templates
iterate-next ;
! #if
: end-false-branch ( label -- )
tail-call? [ %return drop ] [ %jump-label ] if ;
@ -150,12 +150,12 @@ M: #if generate-node
! #dispatch
: dispatch-branch ( node word -- label )
gensym [
rot [
[
copy-templates
%save-dispatch-xt
%prologue-later
[ generate-nodes ] with-node-iterator
] generate-1
] with-generator
] keep ;
: tail-dispatch? ( node -- ? )
@ -182,10 +182,10 @@ M: #dispatch generate-node
generate-dispatch iterate-next
] [
compiling-word get gensym [
rot [
[
init-generate-nodes
generate-dispatch
] generate-1
] with-generator
] keep generate-call
] if ;
@ -224,10 +224,11 @@ M: #dispatch generate-node
: define-if-intrinsic ( word quot inputs -- )
2array 1array define-if-intrinsics ;
: do-if-intrinsic ( #call pair -- next )
<label> [ swap do-template ] keep
>r node-successor r> generate-if
node-successor ;
: do-if-intrinsic ( pair -- next )
<label> [
swap do-template
node> node-successor dup >node
] keep generate-if ;
: find-intrinsic ( #call -- pair/f )
intrinsics find-template ;
@ -249,7 +250,7 @@ M: #call generate-node
] [
node-param generate-call
] ?if
] if* ;
] ?if ;
! #call-label
M: #call-label generate-node node-param generate-call ;
@ -274,4 +275,6 @@ M: #r> generate-node
iterate-next ;
! #return
M: #return generate-node drop end-basic-block %return f ;
M: #return generate-node
node-param compiling-label get eq? compiling-loop? get and
[ end-basic-block %return ] unless f ;

View File

@ -97,11 +97,13 @@ M: object flatten-curry , ;
: node-child node-children first ;
TUPLE: #label word ;
TUPLE: #label word loop? ;
: #label ( word label -- node )
\ #label param-node [ set-#label-word ] keep ;
PREDICATE: #label #loop #label-loop? ;
TUPLE: #entry ;
: #entry ( -- node ) \ #entry all-out-node ;
@ -304,3 +306,15 @@ SYMBOL: node-stack
node-children
[ last-node ] map
[ #terminate? not ] subset ;
DEFER: #tail?
PREDICATE: #merge #tail-merge node-successor #tail? ;
PREDICATE: #values #tail-values node-successor #tail? ;
UNION: #tail
POSTPONE: f #return #tail-values #tail-merge ;
: tail-call? ( -- ? )
node-stack get [ node-successor #tail? ] all? ;

View File

@ -141,37 +141,6 @@ C: <pathname> pathname
M: pathname <=> [ pathname-string ] compare ;
HOOK: library-roots io-backend ( -- seq )
HOOK: binary-roots io-backend ( -- seq )
: find-file ( seq str -- path/f )
[
[ path+ exists? ] curry find nip
] keep over [ path+ ] [ drop ] if ;
: find-library ( str -- path/f )
library-roots swap find-file ;
: find-binary ( str -- path/f )
binary-roots swap find-file ;
<PRIVATE
: append-path ( path files -- paths )
[ path+ ] with map ;
: get-paths ( dir -- paths )
dup directory keys append-path ;
: (walk-dir) ( path -- )
dup directory? [
get-paths dup % [ (walk-dir) ] each
] [
drop
] if ;
PRIVATE>
: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ;
: file-lines ( path -- seq ) <file-reader> lines ;
: file-contents ( path -- str )

View File

@ -367,6 +367,10 @@ DEFER: (flat-length)
dup node-param dup +inlined+ depends-on
word-def splice-quot ;
: method-body-inline? ( #call -- ? )
node-param dup method-body?
[ flat-length 8 <= ] [ drop f ] if ;
M: #call optimize-node*
{
{ [ dup flush-eval? ] [ flush-eval ] }
@ -375,5 +379,6 @@ M: #call optimize-node*
{ [ dup optimizer-hook ] [ optimize-hook ] }
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
{ [ dup optimistic-inline? ] [ optimistic-inline ] }
{ [ dup method-body-inline? ] [ optimistic-inline ] }
{ [ t ] [ inline-method ] }
} cond dup not ;

View File

@ -0,0 +1,62 @@
IN: temporary
USING: tools.test optimizer.control combinators kernel
sequences inference.dataflow math inference ;
: label-is-loop? ( node word -- ? )
[
{
{ [ over #label? not ] [ 2drop f ] }
{ [ over #label-word over eq? not ] [ 2drop f ] }
{ [ over #label-loop? not ] [ 2drop f ] }
{ [ t ] [ 2drop t ] }
} cond
] curry node-exists? ;
: label-is-not-loop? ( node word -- ? )
[
{
{ [ over #label? not ] [ 2drop f ] }
{ [ over #label-word over eq? not ] [ 2drop f ] }
{ [ over #label-loop? ] [ 2drop f ] }
{ [ t ] [ 2drop t ] }
} cond
] curry node-exists? ;
: loop-test-1 ( a -- )
dup [ 1+ loop-test-1 ] [ drop ] if ; inline
[ t ] [
[ loop-test-1 ] dataflow dup detect-loops
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ loop-test-1 1 2 3 ] dataflow dup detect-loops
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ [ loop-test-1 ] each ] dataflow dup detect-loops
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ [ loop-test-1 ] each ] dataflow dup detect-loops
\ (each-integer) label-is-loop?
] unit-test
: loop-test-2 ( a -- )
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline
[ t ] [
[ loop-test-2 ] dataflow dup detect-loops
\ loop-test-2 label-is-not-loop?
] unit-test
: loop-test-3 ( a -- )
dup [ [ loop-test-3 ] each ] [ drop ] if ; inline
[ t ] [
[ loop-test-3 ] dataflow dup detect-loops
\ loop-test-3 label-is-not-loop?
] unit-test

View File

@ -0,0 +1,36 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel inference.dataflow combinators sequences
namespaces math ;
IN: optimizer.control
GENERIC: detect-loops* ( node -- )
M: node detect-loops* drop ;
M: #label detect-loops* t swap set-#label-loop? ;
: not-a-loop ( #label -- )
f swap set-#label-loop? ;
: tail-call? ( -- ? )
node-stack get
dup [ #label? ] find-last drop [ 1+ ] [ 0 ] if* tail
[ node-successor #tail? ] all? ;
: detect-loop ( seen-other? label node -- seen-other? continue? )
#! seen-other?: have we seen another label?
{
{ [ dup #label? not ] [ 2drop t ] }
{ [ 2dup node-param eq? not ] [ 3drop t t ] }
{ [ tail-call? not ] [ not-a-loop drop f ] }
{ [ pick ] [ not-a-loop drop f ] }
{ [ t ] [ 2drop f ] }
} cond ;
M: #call-label detect-loops*
f swap node-param node-stack get <reversed>
[ detect-loop ] with all? 2drop ;
: detect-loops ( node -- )
[ detect-loops* ] each-node ;

View File

@ -1,7 +1,8 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces optimizer.backend optimizer.def-use
optimizer.known-words optimizer.math inference.class ;
optimizer.known-words optimizer.math optimizer.control
inference.class ;
IN: optimizer
: optimize-1 ( node -- newnode ? )
@ -11,6 +12,7 @@ IN: optimizer
H{ } clone value-substitutions set
dup compute-def-use
kill-values
! dup detect-loops
dup infer-classes
optimizer-changed off
optimize-nodes

View File

@ -24,16 +24,18 @@ IN: optimizer.specializers
\ dispatch ,
] [ ] make ;
: specializer-methods ( word -- alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
[ declare ] curry pick append
] { } map>assoc ;
: specialized-def ( word -- quot )
dup word-def swap "specializer" word-prop [
dup { number } = [
drop tag-specializer
] [
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
[ declare ] curry pick append
] { } map>assoc
alist>quot
specializer-methods alist>quot
] if
] when* ;

View File

@ -1,12 +1,14 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vocabs vocabs.loader tools.time tools.browser
arrays assocs io.styles io help.markup prettyprint sequences ;
arrays assocs io.styles io help.markup prettyprint sequences
continuations debugger ;
IN: benchmark
: run-benchmark ( vocab -- result )
"=== Benchmark " write dup print flush
dup require [ run ] benchmark 2array
dup require
[ [ run ] benchmark ] [ error. f f ] recover 2array
dup . ;
: run-benchmarks ( -- assoc )

View File

@ -1 +0,0 @@
Slava Pestov

View File

@ -1,14 +0,0 @@
USING: io.files io.launcher system bootstrap.image
namespaces sequences kernel ;
IN: benchmark.bootstrap2
: bootstrap-benchmark
"." resource-path cd
[
vm ,
"-i=" my-boot-image-name append ,
"-output-image=foo.image" ,
"-no-user-init" ,
] { } make try-process ;
MAIN: bootstrap-benchmark

View File

@ -0,0 +1,110 @@
! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=fasta&lang=java&id=2
USING: math kernel io io.files locals multiline assocs sequences
sequences.private benchmark.reverse-complement hints
byte-arrays float-arrays ;
IN: benchmark.fasta
: IM 139968 ; inline
: IA 3877 ; inline
: IC 29573 ; inline
: initial-seed 42 ; inline
: line-length 60 ; inline
USE: math.private
: random ( seed -- n seed )
>float IA * IC + IM mod [ IM /f ] keep ; inline
HINTS: random fixnum ;
: ALU "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA" ; inline
: IUB
{
{ CHAR: a 0.27 }
{ CHAR: c 0.12 }
{ CHAR: g 0.12 }
{ CHAR: t 0.27 }
{ CHAR: B 0.02 }
{ CHAR: D 0.02 }
{ CHAR: H 0.02 }
{ CHAR: K 0.02 }
{ CHAR: M 0.02 }
{ CHAR: N 0.02 }
{ CHAR: R 0.02 }
{ CHAR: S 0.02 }
{ CHAR: V 0.02 }
{ CHAR: W 0.02 }
{ CHAR: Y 0.02 }
} ; inline
: homo-sapiens
{
{ CHAR: a 0.3029549426680 }
{ CHAR: c 0.1979883004921 }
{ CHAR: g 0.1975473066391 }
{ CHAR: t 0.3015094502008 }
} ; inline
: make-cumulative ( freq -- chars floats )
dup keys >byte-array
swap values >float-array unclip [ + ] accumulate swap add ;
:: select-random | seed chars floats |
floats seed random -rot
[ >= ] curry find drop
chars nth-unsafe ; inline
: make-random-fasta ( seed len chars floats -- seed )
[ rot drop select-random ] 2curry B{ } map-as print ; inline
: write-description ( desc id -- )
">" write write bl print ; inline
:: split-lines | n quot |
n line-length /mod
[ [ line-length quot call ] times ] dip
dup zero? [ drop ] quot if ; inline
: write-random-fasta ( seed n chars floats desc id -- seed )
write-description
[ make-random-fasta ] 2curry split-lines ; inline
:: make-repeat-fasta | k len alu |
[let | kn [ alu length ] |
len [ k + kn mod alu nth-unsafe ] B{ } map-as print
k len +
] ; inline
: write-repeat-fasta ( n alu desc id -- )
write-description
[let | k! [ 0 ] alu [ ] |
[| len | k len alu make-repeat-fasta k! ] split-lines
] with-locals ; inline
: fasta ( n out -- )
homo-sapiens make-cumulative
IUB make-cumulative
[let | homo-sapiens-floats [ ]
homo-sapiens-chars [ ]
IUB-floats [ ]
IUB-chars [ ]
out [ ]
n [ ]
seed [ initial-seed ] |
out [
n 2 * ALU "Homo sapiens alu" "ONE" write-repeat-fasta
initial-seed
n 3 * homo-sapiens-chars homo-sapiens-floats "IUB ambiguity codes" "TWO" write-random-fasta
n 5 * IUB-chars IUB-floats "Homo sapiens frequency" "THREE" write-random-fasta
drop
] with-file-out
] with-locals ;
: run-fasta 2500000 reverse-complement-in fasta ;
MAIN: run-fasta

View File

@ -36,10 +36,17 @@ HINTS: do-line vector string ;
500000 <vector> (reverse-complement)
] with-stream ;
: reverse-complement-in
"extra/benchmark/reverse-complement/reverse-complement-in.txt"
resource-path ;
: reverse-complement-out
"extra/benchmark/reverse-complement/reverse-complement-out.txt"
resource-path ;
: reverse-complement-main ( -- )
"extra/benchmark/reverse-complement/reverse-complement-test-in.txt"
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
[ resource-path ] 2apply
reverse-complement-in
reverse-complement-out
reverse-complement ;
MAIN: reverse-complement-main

View File

@ -1,9 +1,9 @@
USING: kernel io io.files io.launcher io.sockets hashtables math threads
system continuations namespaces sequences splitting math.parser
USING: kernel parser io io.files io.launcher io.sockets hashtables math threads
arrays system continuations namespaces sequences splitting math.parser
prettyprint tools.time calendar bake vars http.client
combinators bootstrap.image bootstrap.image.download
combinators.cleave ;
combinators.cleave benchmark ;
IN: builder
@ -11,20 +11,7 @@ IN: builder
: runtime ( quot -- time ) benchmark nip ;
: log-runtime ( quot file -- )
>r runtime r> <file-writer> [ . ] with-stream ;
: log-object ( object file -- ) <file-writer> [ . ] with-stream ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: datestamp ( -- string )
now `{ ,[ dup timestamp-year ]
,[ dup timestamp-month ]
,[ dup timestamp-day ]
,[ dup timestamp-hour ]
,[ timestamp-minute ] }
[ pad-00 ] map "-" join ;
: minutes>ms ( min -- ms ) 60 * 1000 * ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -48,23 +35,8 @@ SYMBOL: builder-recipients
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: run-or-notify ( desc message -- )
[ [ try-process ] curry ]
[ [ email-string throw ] curry ]
bi*
recover ;
: run-or-send-file ( desc message file -- )
>r >r [ try-process ] curry
r> r> [ email-file throw ] 2curry
recover ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: factor-binary ( -- name )
os
{ { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
@ -72,12 +44,6 @@ SYMBOL: builder-recipients
[ drop "./factor" ] }
case ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: stamp
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-pull ( -- desc )
{
"git"
@ -89,16 +55,30 @@ VAR: stamp
: git-clone ( -- desc ) { "git" "clone" "../factor" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: datestamp ( -- string )
now `{ ,[ dup timestamp-year ]
,[ dup timestamp-month ]
,[ dup timestamp-day ]
,[ dup timestamp-hour ]
,[ timestamp-minute ] }
[ pad-00 ] map "-" join ;
VAR: stamp
: enter-build-dir ( -- )
datestamp >stamp
"/builds" cd
stamp> make-directory
stamp> cd ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-id ( -- id )
{ "git" "show" } <process-stream> [ readln ] with-stream " " split second ;
: record-git-id ( -- ) git-id "../git-id" log-object ;
: record-git-id ( -- ) git-id "../git-id" [ . ] with-file-out ;
: make-clean ( -- desc ) { "make" "clean" } ;
@ -110,13 +90,6 @@ VAR: stamp
}
>hashtable ;
: retrieve-boot-image ( -- )
[ my-arch download-image ]
[ ]
[ "builder: image download" email-string ]
cleanup
flush ;
: bootstrap ( -- desc )
`{
{ +arguments+ {
@ -126,46 +99,92 @@ VAR: stamp
} }
{ +stdout+ "../boot-log" }
{ +stderr+ +stdout+ }
}
>hashtable ;
{ +timeout+ ,[ 20 minutes>ms ] }
} ;
: builder-test ( -- desc ) `{ ,[ factor-binary ] "-run=builder.test" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: build-status
: build ( -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
enter-build-dir
: milli-seconds>time ( n -- string )
1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
: eval-file ( file -- obj ) <file-reader> contents eval ;
git-clone "git clone error" run-or-notify
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
"factor" cd
: cat ( file -- ) <file-reader> contents print ;
record-git-id
make-clean "make clean error" run-or-notify
make-vm "vm compile error" "../compile-log" run-or-send-file
retrieve-boot-image
bootstrap "bootstrap error" "../boot-log" run-or-send-file
builder-test "builder.test fatal error" run-or-notify
"../load-everything-log" exists?
[ "load-everything" "../load-everything-log" email-file ]
when
"../failing-tests" exists?
[ "failing tests" "../failing-tests" email-file ]
when ;
: run-or-bail ( desc quot -- )
[ [ try-process ] curry ]
[ [ throw ] curry ]
bi*
recover ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: minutes>ms ( min -- ms ) 60 * 1000 * ;
: (build) ( -- )
enter-build-dir
"report" [
"Build machine: " write host-name print
"Build directory: " write cwd print
git-clone [ "git clone failed" print ] run-or-bail
"factor" cd
record-git-id
make-clean run-process drop
make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail
[ my-arch download-image ] [ "Image download error" print throw ] recover
! bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
! bootstrap
! <process-stream> dup dispose process-stream-process wait-for-process
! zero? not
! [ "Bootstrap error" print "../boot-log" cat "bootstrap error" throw ]
! when
[
bootstrap
<process-stream> dup dispose process-stream-process wait-for-process
zero? not
[ "bootstrap non-zero" throw ]
when
]
[ "Bootstrap error" print "../boot-log" cat "bootstrap" throw ]
recover
[ builder-test try-process ]
[ "Builder test error" print throw ]
recover
"Boot time: " write "../boot-time" eval-file milli-seconds>time print
"Load time: " write "../load-time" eval-file milli-seconds>time print
"Test time: " write "../test-time" eval-file milli-seconds>time print
"Did not pass load-everything: " print "../load-everything-vocabs" cat
"Did not pass test-all: " print "../test-all-vocabs" cat
"Benchmarks: " print
"../benchmarks" [ stdio get contents eval ] with-file-in benchmarks.
] with-file-out ;
: build ( -- )
[ (build) ] [ drop ] recover
"report" "../report" email-file ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: updates-available? ( -- ? )
git-id

View File

@ -1,28 +1,27 @@
USING: kernel sequences assocs builder continuations vocabs vocabs.loader
USING: kernel namespaces sequences assocs builder continuations
vocabs vocabs.loader
io
io.files
prettyprint
tools.browser
tools.test ;
tools.test
bootstrap.stage2 benchmark ;
IN: builder.test
: try-everything* ( -- vocabs ) try-everything [ first vocab-link-name ] map ;
: do-load ( -- )
[ try-everything* ] "../load-everything-time" log-runtime
dup empty?
[ drop ]
[ "../load-everything-log" log-object ]
if ;
try-everything keys "../load-everything-vocabs" [ . ] with-file-out ;
: do-tests ( -- )
run-all-tests keys
dup empty?
[ drop ]
[ "../failing-tests" log-object ]
if ;
run-all-tests keys "../test-all-vocabs" [ . ] with-file-out ;
: do-all ( -- ) do-load do-tests ;
: do-benchmarks ( -- ) run-benchmarks "../benchmarks" [ . ] with-file-out ;
: do-all ( -- )
bootstrap-time get "../boot-time" [ . ] with-file-out
[ do-load ] runtime "../load-time" [ . ] with-file-out
[ do-tests ] runtime "../test-time" [ . ] with-file-out
do-benchmarks ;
MAIN: do-all

View File

@ -1,6 +1,5 @@
USING: arrays bunny.model combinators.lib continuations
kernel multiline opengl opengl.shaders opengl.capabilities
opengl.gl sequences ;
USING: arrays bunny.model continuations kernel multiline opengl opengl.shaders
opengl.capabilities opengl.gl sequences sequences.lib ;
IN: bunny.cel-shaded
STRING: vertex-shader-source

View File

@ -1,9 +1,8 @@
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 ;
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.cleave float-arrays continuations namespaces
sequences.lib ;
IN: bunny.model
: numbers ( str -- seq )

View File

@ -1,5 +1,5 @@
USING: combinators.lib kernel math math.ranges random sequences
tools.test continuations arrays vectors ;
USING: combinators.lib kernel math random sequences tools.test continuations
arrays vectors ;
IN: temporary
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.launcher io.styles io hashtables kernel
sequences combinators.lib assocs system sorting math.parser ;
sequences sequences.lib assocs system sorting math.parser ;
IN: contributors
: changelog ( -- authors )

View File

@ -1,35 +1,45 @@
! Copyright (C) 2006 Slava Pestov
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax kernel math sequences ;
IN: core-foundation
TYPEDEF: void* CFAllocatorRef
TYPEDEF: void* CFArrayRef
TYPEDEF: void* CFBundleRef
TYPEDEF: void* CFStringRef
TYPEDEF: void* CFURLRef
TYPEDEF: void* CFUUIDRef
TYPEDEF: void* CFRunLoopRef
TYPEDEF: bool Boolean
TYPEDEF: int CFIndex
TYPEDEF: double CFTimeInterval
TYPEDEF: double CFAbsoluteTime
FUNCTION: void* CFArrayCreateMutable ( void* allocator, CFIndex capacity, void* callbacks ) ;
FUNCTION: CFArrayRef CFArrayCreateMutable ( CFAllocatorRef allocator, CFIndex capacity, void* callbacks ) ;
FUNCTION: void* CFArrayGetValueAtIndex ( void* array, CFIndex idx ) ;
FUNCTION: void* CFArrayGetValueAtIndex ( CFArrayRef array, CFIndex idx ) ;
FUNCTION: void CFArraySetValueAtIndex ( void* array, CFIndex index, void* value ) ;
FUNCTION: void CFArraySetValueAtIndex ( CFArrayRef array, CFIndex index, void* value ) ;
FUNCTION: CFIndex CFArrayGetCount ( void* array ) ;
FUNCTION: CFIndex CFArrayGetCount ( CFArrayRef array ) ;
: kCFURLPOSIXPathStyle 0 ;
FUNCTION: void* CFURLCreateWithFileSystemPath ( void* allocator, void* filePath, int pathStyle, bool isDirectory ) ;
FUNCTION: CFURLRef CFURLCreateWithFileSystemPath ( CFAllocatorRef allocator, CFStringRef filePath, int pathStyle, Boolean isDirectory ) ;
FUNCTION: void* CFURLCreateWithString ( void* allocator, void* string, void* base ) ;
FUNCTION: CFURLRef CFURLCreateWithString ( CFAllocatorRef allocator, CFStringRef string, CFURLRef base ) ;
FUNCTION: void* CFURLCopyFileSystemPath ( void* url, int pathStyle ) ;
FUNCTION: CFURLRef CFURLCopyFileSystemPath ( CFURLRef url, int pathStyle ) ;
FUNCTION: void* CFStringCreateWithCharacters ( void* allocator, ushort* cStr, CFIndex numChars ) ;
FUNCTION: CFStringRef CFStringCreateWithCharacters ( CFAllocatorRef allocator, ushort* cStr, CFIndex numChars ) ;
FUNCTION: CFIndex CFStringGetLength ( void* theString ) ;
FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ;
FUNCTION: void* CFBundleCreate ( void* allocator, void* bundleURL ) ;
FUNCTION: CFBundleRef CFBundleCreate ( CFAllocatorRef allocator, CFURLRef bundleURL ) ;
FUNCTION: bool CFBundleLoadExecutable ( void* bundle ) ;
FUNCTION: Boolean CFBundleLoadExecutable ( CFBundleRef bundle ) ;
FUNCTION: void CFRelease ( void* cf ) ;
@ -52,6 +62,9 @@ FUNCTION: void CFRelease ( void* cf ) ;
: CF>string-array ( alien -- seq )
CF>array [ CF>string ] map ;
: <CFStringArray> ( seq -- alien )
[ <CFString> ] map dup <CFArray> swap [ CFRelease ] each ;
: <CFFileSystemURL> ( string dir? -- url )
>r <CFString> f over kCFURLPOSIXPathStyle
r> CFURLCreateWithFileSystemPath swap CFRelease ;
@ -72,3 +85,5 @@ FUNCTION: void CFRelease ( void* cf ) ;
] [
"Cannot load bundled named " swap append throw
] ?if ;
FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;

View File

@ -0,0 +1,203 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax kernel math sequences
namespaces assocs init continuations core-foundation ;
IN: core-foundation.fsevents
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! FSEventStream API, Leopard only !
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
: kFSEventStreamCreateFlagUseCFTypes 2 ; inline
: kFSEventStreamCreateFlagWatchRoot 4 ; inline
: kFSEventStreamEventFlagMustScanSubDirs 1 ; inline
: kFSEventStreamEventFlagUserDropped 2 ; inline
: kFSEventStreamEventFlagKernelDropped 4 ; inline
: kFSEventStreamEventFlagEventIdsWrapped 8 ; inline
: kFSEventStreamEventFlagHistoryDone 16 ; inline
: kFSEventStreamEventFlagRootChanged 32 ; inline
: kFSEventStreamEventFlagMount 64 ; inline
: kFSEventStreamEventFlagUnmount 128 ; inline
TYPEDEF: int FSEventStreamCreateFlags
TYPEDEF: int FSEventStreamEventFlags
TYPEDEF: longlong FSEventStreamEventId
TYPEDEF: void* FSEventStreamRef
C-STRUCT: FSEventStreamContext
{ "CFIndex" "version" }
{ "void*" "info" }
{ "void*" "retain" }
{ "void*" "release" }
{ "void*" "copyDescription" } ;
! callback(FSEventStreamRef streamRef, void *clientCallBackInfo, size_t numEvents, void *eventPaths, const FSEventStreamEventFlags eventFlags[], const FSEventStreamEventId eventIds[]);
TYPEDEF: void* FSEventStreamCallback
: FSEventStreamEventIdSinceNow HEX: FFFFFFFFFFFFFFFF ; inline
FUNCTION: FSEventStreamRef FSEventStreamCreate (
CFAllocatorRef allocator,
FSEventStreamCallback callback,
FSEventStreamContext* context,
CFArrayRef pathsToWatch,
FSEventStreamEventId sinceWhen,
CFTimeInterval latency,
FSEventStreamCreateFlags flags ) ;
FUNCTION: FSEventStreamRef FSEventStreamCreateRelativeToDevice (
CFAllocatorRef allocator,
FSEventStreamCallback callback,
FSEventStreamContext* context,
dev_t deviceToWatch,
CFArrayRef pathsToWatchRelativeToDevice,
FSEventStreamEventId sinceWhen,
CFTimeInterval latency,
FSEventStreamCreateFlags flags ) ;
FUNCTION: FSEventStreamEventId FSEventStreamGetLatestEventId ( FSEventStreamRef streamRef ) ;
FUNCTION: dev_t FSEventStreamGetDeviceBeingWatched ( FSEventStreamRef streamRef ) ;
FUNCTION: CFArrayRef FSEventStreamCopyPathsBeingWatched ( FSEventStreamRef streamRef ) ;
FUNCTION: FSEventStreamEventId FSEventsGetCurrentEventId ( ) ;
FUNCTION: CFUUIDRef FSEventsCopyUUIDForDevice ( dev_t dev ) ;
FUNCTION: FSEventStreamEventId FSEventsGetLastEventIdForDeviceBeforeTime (
dev_t dev,
CFAbsoluteTime time ) ;
FUNCTION: Boolean FSEventsPurgeEventsForDeviceUpToEventId (
dev_t dev,
FSEventStreamEventId eventId ) ;
FUNCTION: void FSEventStreamRetain ( FSEventStreamRef streamRef ) ;
FUNCTION: void FSEventStreamRelease ( FSEventStreamRef streamRef ) ;
FUNCTION: void FSEventStreamScheduleWithRunLoop (
FSEventStreamRef streamRef,
CFRunLoopRef runLoop,
CFStringRef runLoopMode ) ;
FUNCTION: void FSEventStreamUnscheduleFromRunLoop (
FSEventStreamRef streamRef,
CFRunLoopRef runLoop,
CFStringRef runLoopMode ) ;
FUNCTION: void FSEventStreamInvalidate ( FSEventStreamRef streamRef ) ;
FUNCTION: Boolean FSEventStreamStart ( FSEventStreamRef streamRef ) ;
FUNCTION: FSEventStreamEventId FSEventStreamFlushAsync ( FSEventStreamRef streamRef ) ;
FUNCTION: void FSEventStreamFlushSync ( FSEventStreamRef streamRef ) ;
FUNCTION: void FSEventStreamStop ( FSEventStreamRef streamRef ) ;
FUNCTION: void FSEventStreamShow ( FSEventStreamRef streamRef ) ;
FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef ) ;
: make-FSEventStreamContext ( info -- alien )
"FSEventStreamContext" <c-object>
[ set-FSEventStreamContext-info ] keep ;
: <FSEventStream> ( callback info paths latency flags -- event-stream )
>r >r >r >r >r
f ! allocator
r> ! callback
r> make-FSEventStreamContext
r> <CFStringArray> ! paths
FSEventStreamEventIdSinceNow ! sinceWhen
r> ! latency
r> ! flags
FSEventStreamCreate ;
: kCFRunLoopCommonModes ( -- string )
"kCFRunLoopCommonModes" f dlsym *void* ;
: schedule-event-stream ( event-stream -- )
CFRunLoopGetMain
kCFRunLoopCommonModes
FSEventStreamScheduleWithRunLoop ;
: unschedule-event-stream ( event-stream -- )
CFRunLoopGetMain
kCFRunLoopCommonModes
FSEventStreamUnscheduleFromRunLoop ;
: enable-event-stream ( event-stream -- )
dup
schedule-event-stream
dup FSEventStreamStart [
drop
] [
dup unschedule-event-stream
FSEventStreamRelease
"Cannot enable FSEventStream" throw
] if ;
: disable-event-stream ( event-stream -- )
dup FSEventStreamStop
unschedule-event-stream ;
SYMBOL: event-stream-callbacks
: event-stream-counter \ event-stream-counter counter ;
[
H{ } clone event-stream-callbacks set-global
1 \ event-stream-counter set-global
] "core-foundation" add-init-hook
event-stream-callbacks global [ H{ } assoc-like ] change-at
: add-event-source-callback ( quot -- id )
event-stream-counter <alien>
[ event-stream-callbacks get set-at ] keep ;
: remove-event-source-callback ( id -- )
event-stream-callbacks get delete-at ;
: >event-triple ( n eventPaths eventFlags eventIds -- triple )
[
>r >r >r dup dup
r> char*-nth ,
r> int-nth ,
r> longlong-nth ,
] { } make ;
: master-event-source-callback ( -- alien )
"void"
{
"FSEventStreamRef"
"void*" ! info
"size_t" ! numEvents
"void*" ! eventPaths
"FSEventStreamEventFlags*"
"FSEventStreamEventId*"
}
"cdecl" [
[ >event-triple ] 3curry map
swap event-stream-callbacks get at call
drop
] alien-callback ;
TUPLE: event-stream info handle ;
: <event-stream> ( quot paths latency flags -- event-stream )
>r >r >r
add-event-source-callback dup
>r master-event-source-callback r>
r> r> r> <FSEventStream>
dup enable-event-stream
event-stream construct-boa ;
M: event-stream dispose
dup event-stream-info remove-event-source-callback
event-stream-handle dup disable-event-stream
FSEventStreamRelease ;

26
extra/db/db.factor Normal file → Executable file
View File

@ -15,7 +15,8 @@ TUPLE: db handle insert-statements update-statements delete-statements select-st
GENERIC: db-open ( db -- )
HOOK: db-close db ( handle -- )
: dispose-statements [ dispose drop ] assoc-each ;
: dispose-statements ( seq -- )
[ dispose drop ] assoc-each ;
: dispose-db ( db -- )
dup db [
@ -27,39 +28,36 @@ HOOK: db-close db ( handle -- )
] with-variable ;
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: reset-statement ( statement -- )
GENERIC: execute-statement* ( statement -- result-set )
HOOK: last-id db ( res -- id )
: execute-statement ( statement -- )
execute-statement* dispose ;
GENERIC: execute-statement ( statement -- )
: execute-statement-last-id ( statement -- id )
execute-statement* [ last-id ] with-disposal ;
: bind-statement ( obj statement -- )
2dup dup statement-bound? [
rebind-statement
] [
bind-statement*
] if
tuck set-statement-params
dup statement-bound? [ dup reset-statement ] when
[ bind-statement* ] 2keep
[ set-statement-params ] keep
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 -- ? )
HOOK: last-id db ( -- id )
: init-result-set ( result-set -- )
dup #rows over set-result-set-max
-1 swap set-result-set-n ;

16
extra/db/postgresql/ffi/ffi.factor Normal file → Executable file
View File

@ -1,17 +1,14 @@
! Copyright (C) 2007 Doug Coleman.
! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
! tested on debian linux with postgresql 8.1
USING: alien alien.syntax combinators system ;
IN: db.postgresql.ffi
<<
"postgresql" {
<< "postgresql" {
{ [ win32? ] [ "libpq.dll" ] }
{ [ macosx? ] [ "/opt/local/lib/postgresql81/libpq.dylib" ] }
{ [ unix? ] [ "libpq.so" ] }
} cond "cdecl" add-library
>>
} cond "cdecl" add-library >>
! ConnSatusType
: CONNECTION_OK HEX: 0 ; inline
@ -53,6 +50,8 @@ IN: db.postgresql.ffi
: PQERRORS_DEFAULT HEX: 1 ; inline
: PQERRORS_VERBOSE HEX: 2 ; inline
: InvalidOid 0 ; inline
TYPEDEF: int size_t
TYPEDEF: int ConnStatusType
TYPEDEF: int ExecStatusType
@ -75,7 +74,6 @@ TYPEDEF: void* SSL*
LIBRARY: postgresql
! Exported functions of libpq
! make a new client connection to the backend
@ -102,10 +100,6 @@ FUNCTION: PQconninfoOption* PQconndefaults ( ) ;
! free the data structure returned by PQconndefaults()
FUNCTION: void PQconninfoFree ( PQconninfoOption* connOptions ) ;
!
! close the current connection and restablish a new one with the same
! parameters
!
! Asynchronous (non-blocking)
FUNCTION: int PQresetStart ( PGconn* conn ) ;
FUNCTION: PostgresPollingStatusType PQresetPoll ( PGconn* conn ) ;

View File

@ -37,8 +37,13 @@ IN: db.postgresql.lib
>r db get db-handle r>
[ statement-sql ] keep
[ statement-params length f ] keep
statement-params [ malloc-char-string ] map >c-void*-array
statement-params [ second malloc-char-string ] map >c-void*-array
f f 0 PQexecParams
dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw
] unless ;
: pq-oid-value ( res -- n )
PQoidValue dup InvalidOid = [
"postgresql returned an InvalidOid" throw
] when ;

113
extra/db/postgresql/postgresql.factor Normal file → Executable file
View File

@ -1,8 +1,9 @@
! 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 ;
kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types ;
IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
@ -39,8 +40,8 @@ M: postgresql-db dispose ( db -- )
M: postgresql-statement bind-statement* ( seq statement -- )
set-statement-params ;
M: postgresql-statement rebind-statement ( seq statement -- )
bind-statement* ;
M: postgresql-statement reset-statement ( statement -- )
drop ;
M: postgresql-result-set #rows ( result-set -- n )
result-set-handle PQntuples ;
@ -51,8 +52,8 @@ M: postgresql-result-set #columns ( result-set -- n )
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 ;
M: postgresql-statement execute-statement* ( statement -- obj )
query-results ;
: increment-n ( result-set -- n )
dup result-set-n 1+ dup rot set-result-set-n ;
@ -103,3 +104,103 @@ M: postgresql-db commit-transaction ( -- )
M: postgresql-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
M: postgresql-db create-sql ( columns table -- sql )
[
"create table " % %
" (" % [ ", " % ] [
dup second % " " %
dup third >sql-type % " " %
sql-modifiers " " join %
] interleave ")" %
] "" make ;
M: postgresql-db drop-sql ( table -- sql )
[
"drop table " % %
] "" make ;
SYMBOL: postgresql-counter
M: postgresql-db insert-sql* ( columns table -- sql )
[
postgresql-counter off
"insert into " %
%
"(" %
dup [ ", " % ] [ second % ] interleave
") " %
" values (" %
[ ", " % ] [
drop "$" % postgresql-counter [ inc ] keep get #
] interleave
")" %
] "" make ;
M: postgresql-db update-sql* ( columns table -- sql )
[
"update " %
%
" set " %
dup remove-id
[ ", " % ] [ second dup % " = :" % % ] interleave
" where " %
[ primary-key? ] find nip second dup % " = :" % %
] "" make ;
M: postgresql-db delete-sql* ( columns table -- sql )
[
"delete from " %
%
" where " %
first second dup % " = :" % %
] "" make ;
M: postgresql-db select-sql* ( columns table -- sql )
drop ;
M: postgresql-db tuple>params ( columns tuple -- obj )
[
>r dup first r> get-slot-named swap third
] curry { } map>assoc ;
M: postgresql-db last-id ( res -- id )
pq-oid-value ;
: postgresql-db-modifiers ( -- hashtable )
H{
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
{ +default+ "default" }
{ +null+ "null" }
{ +not-null+ "not null" }
} ;
M: postgresql-db sql-modifiers* ( modifiers -- str )
postgresql-db-modifiers swap [
dup array? [
first2
>r swap at r> number>string*
" " swap 3append
] [
swap at
] if
] with map [ ] subset ;
: postgresql-type-hash ( -- assoc )
H{
{ INTEGER "integer" }
{ TEXT "text" }
{ VARCHAR "text" }
{ DOUBLE "real" }
} ;
M: postgresql-db >sql-type ( obj -- str )
dup pair? [
first >sql-type
] [
postgresql-type-hash at* [ T{ no-sql-type } throw ] unless
] if ;

16
extra/db/sqlite/ffi/ffi.factor Normal file → Executable file
View File

@ -1,17 +1,12 @@
! 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.
! Not all functions have been wrapped.
USING: alien compiler kernel math namespaces sequences strings alien.syntax
system combinators ;
IN: db.sqlite.ffi
<<
"sqlite" {
<< "sqlite" {
{ [ winnt? ] [ "sqlite3.dll" ] }
{ [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
{ [ unix? ] [ "libsqlite3.so" ] }
@ -76,8 +71,9 @@ IN: db.sqlite.ffi
"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 sqlite3_step
: SQLITE_ROW 100 ; inline
: SQLITE_DONE 101 ; inline
! Return values from the sqlite3_column_type function
: SQLITE_INTEGER 1 ; inline
@ -103,7 +99,6 @@ IN: db.sqlite.ffi
: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 ; inline
: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 ; inline
TYPEDEF: void sqlite3
TYPEDEF: void sqlite3_stmt
TYPEDEF: longlong sqlite3_int64
@ -112,6 +107,7 @@ TYPEDEF: ulonglong sqlite3_uint64
LIBRARY: sqlite
FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
FUNCTION: char* sqlite3_errmsg ( 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 ) ;

113
extra/db/sqlite/lib/lib.factor Normal file → Executable file
View File

@ -1,18 +1,25 @@
! 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 ;
USING: alien.c-types arrays assocs kernel math math.parser
namespaces sequences db.sqlite.ffi db combinators
continuations db.types ;
IN: db.sqlite.lib
TUPLE: sqlite-error n message ;
: sqlite-error ( n -- * )
sqlite-error-messages nth throw ;
: sqlite-check-result ( result -- )
dup SQLITE_OK = [
drop
] [
dup sqlite-error-messages nth
sqlite-error construct-boa throw
] if ;
: sqlite-statement-error-string ( -- str )
db get db-handle sqlite3_errmsg ;
: sqlite-statement-error ( -- * )
sqlite-statement-error-string throw ;
: sqlite-check-result ( n -- )
{
{ [ dup SQLITE_OK = ] [ drop ] }
{ [ dup SQLITE_ERROR = ] [ sqlite-statement-error ] }
{ [ t ] [ sqlite-error ] }
} cond ;
: sqlite-open ( filename -- db )
"void*" <c-object>
@ -21,61 +28,83 @@ TUPLE: sqlite-error n message ;
: sqlite-close ( db -- )
sqlite3_close sqlite-check-result ;
: sqlite-prepare ( db sql -- statement )
#! TODO: Support multiple statements in the SQL string.
: sqlite-prepare ( db sql -- handle )
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 )
: sqlite-bind-parameter-index ( handle name -- index )
sqlite3_bind_parameter_index ;
: sqlite-bind-text-by-name ( statement name text -- )
>r dupd sqlite-bind-parameter-index r> sqlite-bind-text ;
: parameter-index ( handle name text -- handle name text )
>r dupd sqlite-bind-parameter-index r> ;
: sqlite-bind-assoc ( statement assoc -- )
swap [
-rot sqlite-bind-text-by-name
] curry assoc-each ;
: sqlite-bind-text ( handle index text -- )
dup length SQLITE_TRANSIENT
sqlite3_bind_text sqlite-check-result ;
: sqlite-finalize ( statement -- )
: sqlite-bind-int ( handle i n -- )
sqlite3_bind_int sqlite-check-result ;
: sqlite-bind-int64 ( handle i n -- )
sqlite3_bind_int64 sqlite-check-result ;
: sqlite-bind-double ( handle i x -- )
sqlite3_bind_double sqlite-check-result ;
: sqlite-bind-null ( handle i -- )
sqlite3_bind_null sqlite-check-result ;
: sqlite-bind-text-by-name ( handle name text -- )
parameter-index sqlite-bind-text ;
: sqlite-bind-int-by-name ( handle name int -- )
parameter-index sqlite-bind-int ;
: sqlite-bind-int64-by-name ( handle name int64 -- )
parameter-index sqlite-bind-int ;
: sqlite-bind-double-by-name ( handle name double -- )
parameter-index sqlite-bind-double ;
: sqlite-bind-null-by-name ( handle name obj -- )
parameter-index drop sqlite-bind-null ;
: sqlite-bind-type ( handle key value type -- )
dup array? [ first ] when
{
{ INTEGER [ sqlite-bind-int-by-name ] }
{ BIG_INTEGER [ sqlite-bind-int-by-name ] }
{ TEXT [ sqlite-bind-text-by-name ] }
{ VARCHAR [ sqlite-bind-text-by-name ] }
{ DOUBLE [ sqlite-bind-double-by-name ] }
! { NULL [ sqlite-bind-null-by-name ] }
[ no-sql-type ]
} case ;
: sqlite-finalize ( handle -- )
sqlite3_finalize sqlite-check-result ;
: sqlite-reset ( statement -- )
: sqlite-reset ( handle -- )
sqlite3_reset sqlite-check-result ;
: sqlite-#columns ( query -- int )
sqlite3_column_count ;
: sqlite-column ( statement index -- string )
! TODO
: sqlite-column ( handle index -- string )
sqlite3_column_text ;
: sqlite-row ( statement -- seq )
! TODO
: sqlite-row ( handle -- 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
dup SQLITE_DONE =
[ drop ] [ sqlite-check-result ] if t
] if ;
: sqlite-next ( prepared -- ? )

View File

@ -1,6 +1,6 @@
USING: io io.files io.launcher kernel namespaces
prettyprint tools.test db.sqlite db sequences
continuations ;
continuations db.types ;
IN: temporary
: test.db "extra/db/sqlite/test.db" resource-path ;
@ -26,13 +26,13 @@ IN: temporary
test.db [
"select * from person where name = :name and country = :country"
<simple-statement> [
{ { ":name" "Jane" } { ":country" "New Zealand" } }
{ { ":name" "Jane" TEXT } { ":country" "New Zealand" TEXT } }
over do-bound-query
{ { "Jane" "New Zealand" } } =
[ "test fails" throw ] unless
{ { ":name" "John" } { ":country" "America" } }
{ { ":name" "John" TEXT } { ":country" "America" TEXT } }
swap do-bound-query
] with-disposal
] with-sqlite

44
extra/db/sqlite/sqlite.factor Normal file → Executable file
View File

@ -25,7 +25,7 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
TUPLE: sqlite-statement ;
C: <sqlite-statement> sqlite-statement
TUPLE: sqlite-result-set ;
TUPLE: sqlite-result-set advanced? ;
: <sqlite-result-set> ( query -- sqlite-result-set )
dup statement-handle sqlite-result-set <result-set> ;
@ -40,18 +40,26 @@ M: sqlite-db <prepared-statement> ( str -- obj )
M: sqlite-statement dispose ( statement -- )
statement-handle sqlite-finalize ;
: maybe-advance-row ( result-set -- result-set )
dup sqlite-result-set-advanced? [
dup advance-row drop
] unless ;
M: sqlite-result-set dispose ( result-set -- )
maybe-advance-row
f swap set-result-set-handle ;
M: sqlite-statement bind-statement* ( assoc statement -- )
statement-handle swap sqlite-bind-assoc ;
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
M: sqlite-statement rebind-statement ( assoc statement -- )
dup statement-handle sqlite-reset
statement-handle swap sqlite-bind-assoc ;
M: sqlite-statement bind-statement* ( triples statement -- )
statement-handle sqlite-bind ;
M: sqlite-statement execute-statement ( statement -- )
statement-handle sqlite-next drop ;
M: sqlite-statement reset-statement ( statement -- )
statement-handle sqlite-reset ;
M: sqlite-statement execute-statement* ( statement -- obj )
query-results ;
M: sqlite-result-set #columns ( result-set -- n )
result-set-handle sqlite-#columns ;
@ -60,7 +68,8 @@ 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 ;
[ result-set-handle sqlite-next ] keep
t swap set-sqlite-result-set-advanced? ;
M: sqlite-statement query-results ( query -- result-set )
dup statement-handle sqlite-result-set <result-set> ;
@ -118,7 +127,7 @@ M: sqlite-db delete-sql* ( columns table -- sql )
%
" where " %
first second dup % " = :" % %
] "" make dup . ;
] "" make ;
M: sqlite-db select-sql* ( columns table -- sql )
[
@ -131,13 +140,15 @@ M: sqlite-db select-sql* ( columns table -- sql )
M: sqlite-db tuple>params ( columns tuple -- obj )
[
>r [ second ":" swap append ] keep first r> get-slot-named
number>string*
] curry { } map>assoc ;
>r [ second ":" swap append ] keep r>
dupd >r first r> get-slot-named swap
third 3array
] curry map ;
M: sqlite-db last-id ( -- id )
db get db-handle sqlite3_last_insert_rowid ;
M: sqlite-db last-id ( result-set -- id )
maybe-advance-row drop
db get db-handle sqlite3_last_insert_rowid
dup zero? [ "last-id failed" throw ] when ;
: sqlite-db-modifiers ( -- hashtable )
H{
@ -166,6 +177,7 @@ M: sqlite-db sql-modifiers* ( modifiers -- str )
{ INTEGER "integer" }
{ TEXT "text" }
{ VARCHAR "text" }
{ DOUBLE "real" }
} ;
M: sqlite-db >sql-type ( obj -- str )

64
extra/db/tuples/tuples-tests.factor Normal file → Executable file
View File

@ -1,26 +1,26 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel tools.test db db.sqlite db.tuples
db.types continuations namespaces ;
db.types continuations namespaces db.postgresql math
tools.time ;
IN: temporary
TUPLE: person the-id the-name the-number ;
: <person> ( name age -- person )
{ set-person-the-name set-person-the-number } person construct ;
person "PERSON"
{
{ "the-id" "ROWID" INTEGER +native-id+ }
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
{ "the-number" "AGE" INTEGER { +default+ 0 } }
} define-persistent
TUPLE: person the-id the-name the-number real ;
: <person> ( name age real -- person )
{
set-person-the-name
set-person-the-number
set-person-real
} person construct ;
: <assigned-person> ( id name number real -- obj )
<person> [ set-person-the-id ] keep ;
SYMBOL: the-person
: test-tuples ( -- )
[ person drop-table ] [ ] recover
person create-table
f "billy" 100 person construct-boa
the-person set
[ person drop-table ] [ drop ] recover
[ ] [ person create-table ] unit-test
[ ] [ the-person get insert-tuple ] unit-test
@ -37,9 +37,33 @@ SYMBOL: the-person
test-tuples
] with-db ;
test-sqlite
: test-postgresql ( -- )
"localhost" "postgres" "" "factor-test" <postgresql-db> [
test-tuples
] with-db ;
! : test-postgres ( -- )
! resource-path <postgresql-db> [
! test-tuples
! ] with-db ;
person "PERSON"
{
{ "the-id" "ROWID" INTEGER +native-id+ }
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
{ "the-number" "AGE" INTEGER { +default+ 0 } }
{ "real" "REAL" DOUBLE { +default+ 0.3 } }
} define-persistent
"billy" 10 3.14 <person> the-person set
test-sqlite
! test-postgresql
person "PERSON"
{
{ "the-id" "ROWID" INTEGER +assigned-id+ }
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
{ "the-number" "AGE" INTEGER { +default+ 0 } }
{ "real" "REAL" DOUBLE { +default+ 0.3 } }
} define-persistent
1 "billy" 20 6.28 <assigned-person> the-person set
test-sqlite
! test-postgresql

54
extra/db/tuples/tuples.factor Normal file → Executable file
View File

@ -1,37 +1,28 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes db kernel namespaces
tuples words sequences slots slots.private math
math.parser io prettyprint db.types ;
USE: continuations
math.parser io prettyprint db.types continuations ;
IN: db.tuples
! only take a tuple if you have to extract things from it
! otherwise take a class
! primary-key vs primary-key-spec
! define-persistent should enforce a primary key
! in sqlite, defining a new primary key makes it an alias for rowid, _rowid_, and oid
! -sql outputs sql code
! table - string
! columns - seq of column specifiers
: db-columns ( class -- obj )
"db-columns" word-prop ;
: db-table ( class -- obj )
"db-table" word-prop ;
: db-columns ( class -- obj ) "db-columns" word-prop ;
: db-table ( class -- obj ) "db-table" word-prop ;
TUPLE: no-slot-named ;
: no-slot-named ( -- * ) T{ no-slot-named } throw ;
: slot-spec-named ( str class -- slot-spec )
"slots" word-prop [ slot-spec-name = ] with find nip ;
"slots" word-prop [ slot-spec-name = ] with find nip
[ no-slot-named ] unless* ;
: offset-of-slot ( str obj -- n )
class slot-spec-named slot-spec-offset ;
: get-slot-named ( str obj -- value )
tuck offset-of-slot slot ;
tuck offset-of-slot [ no-slot-named ] unless* slot ;
: set-slot-named ( value str obj -- )
tuck offset-of-slot set-slot ;
tuck offset-of-slot [ no-slot-named ] unless* set-slot ;
: primary-key-spec ( class -- spec )
db-columns [ primary-key? ] find nip ;
@ -43,7 +34,6 @@ IN: db.tuples
[ class primary-key-spec first ] keep
set-slot-named ;
: cache-statement ( columns class assoc quot -- statement )
[ db-table dupd ] swap
[ <prepared-statement> ] 3compose cache nip ; inline
@ -71,11 +61,15 @@ HOOK: tuple>params db ( columns tuple -- obj )
: tuple-statement ( columns tuple quot -- statement )
>r [ tuple>params ] 2keep class r> call
2dup . .
[ bind-statement ] keep ;
: do-tuple-statement ( tuple columns-quot statement-quot -- )
: make-tuple-statement ( tuple columns-quot statement-quot -- statement )
>r [ class db-columns ] swap compose keep
r> tuple-statement dup . execute-statement ;
r> tuple-statement ;
: do-tuple-statement ( tuple columns-quot statement-quot -- )
make-tuple-statement execute-statement ;
: create-table ( class -- )
dup db-columns swap db-table create-sql sql-command ;
@ -85,8 +79,8 @@ HOOK: tuple>params db ( columns tuple -- obj )
: insert-tuple ( tuple -- )
[
[ maybe-remove-id ] [ insert-sql ] do-tuple-statement
last-id
[ maybe-remove-id ] [ insert-sql ]
make-tuple-statement execute-statement-last-id
] keep set-primary-key ;
: update-tuple ( tuple -- )
@ -101,19 +95,9 @@ HOOK: tuple>params db ( columns tuple -- obj )
: persist ( tuple -- )
dup primary-key [ update-tuple ] [ insert-tuple ] if ;
! PERSISTENT:
: define-persistent ( class table columns -- )
>r dupd "db-table" set-word-prop r>
"db-columns" set-word-prop ;
: define-relation ( spec -- )
drop ;

36
extra/db/types/types.factor Normal file → Executable file
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs db kernel math math.parser
sequences continuations ;
IN: db.types
! id serial not null primary key,
! ID is the Primary key
SYMBOL: +native-id+
SYMBOL: +assigned-id+
@ -19,15 +19,8 @@ SYMBOL: +unique+
SYMBOL: +default+
SYMBOL: +null+
SYMBOL: +not-null+
SYMBOL: +has-many+
! SQLite Types
! http://www.sqlite.org/datatype3.html
! SYMBOL: NULL
! SYMBOL: INTEGER
! SYMBOL: REAL
! SYMBOL: TEXT
! SYMBOL: BLOB
SYMBOL: +has-many+
SYMBOL: INTEGER
SYMBOL: DOUBLE
@ -41,24 +34,16 @@ SYMBOL: DATE
SYMBOL: BIG_INTEGER
! SYMBOL: LOCALE
! SYMBOL: TIMEZONE
! SYMBOL: CURRENCY
! PostgreSQL Types
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
: number>string* ( num/str -- str )
dup number? [ number>string ] when ;
TUPLE: no-sql-type ;
: no-sql-type ( -- * ) T{ no-sql-type } throw ;
HOOK: sql-modifiers* db ( modifiers -- str )
HOOK: >sql-type db ( obj -- str )
! HOOK: >factor-type db ( obj -- obj )
: number>string* ( n/str -- str )
dup number? [ number>string ] when ;
: maybe-remove-id ( columns -- obj )
[ +native-id+ swap member? not ] subset ;
@ -68,3 +53,8 @@ HOOK: >sql-type db ( obj -- str )
: sql-modifiers ( spec -- seq )
3 tail sql-modifiers* ;
! SQLite Types: http://www.sqlite.org/datatype3.html
! NULL INTEGER REAL TEXT BLOB
! PostgreSQL Types:
! http://developer.postgresql.org/pgdocs/postgres/datatype.html

View File

@ -1,12 +1,12 @@
USING: definitions kernel parser words sequences math.parser
namespaces editors io.launcher windows.shell32 io.files
io.paths strings ;
io.paths strings unicode.case ;
IN: editors.editpadpro
: editpadpro-path
\ editpadpro-path get-global [
program-files "JGsoft" path+ walk-dir
[ >lower "editpadpro.exe" tail? ] find nip
program-files "JGsoft" path+
[ >lower "editpadpro.exe" tail? ] find-file-breadth
] unless* ;
: editpadpro ( file line -- )

View File

@ -4,7 +4,7 @@ IN: editors.editplus
: editplus-path ( -- path )
\ editplus-path get-global [
program-files "\\EditPlus 2\\editplus.exe" append
program-files "\\EditPlus 2\\editplus.exe" path+
] unless* ;
: editplus ( file line -- )

View File

@ -1,8 +1,9 @@
USING: editors.gvim.backend io.files io.windows kernel namespaces
sequences windows.shell32 ;
sequences windows.shell32 io.paths ;
IN: editors.gvim.windows
M: windows-io gvim-path
\ gvim-path get-global [
program-files walk-dir [ "gvim.exe" tail? ] find nip
program-files "vim" path+
[ "gvim.exe" tail? ] find-file-breadth
] unless* ;

View File

@ -1,10 +1,11 @@
USING: editors hardware-info.windows io.launcher kernel
math.parser namespaces sequences windows.shell32 ;
math.parser namespaces sequences windows.shell32 io.files
arrays ;
IN: editors.wordpad
: wordpad-path ( -- path )
\ wordpad-path get [
program-files "\\Windows NT\\Accessories\\wordpad.exe" append
program-files "\\Windows NT\\Accessories\\wordpad.exe" path+
] unless* ;
: wordpad ( file line -- )

View File

@ -1,7 +1,5 @@
USING: kernel combinators sequences math math.functions math.vectors mortar slot-accessors
x x.widgets.wm.root x.widgets.wm.frame combinators.lib ;
USING: kernel combinators sequences math math.functions math.vectors mortar
slot-accessors x x.widgets.wm.root x.widgets.wm.frame sequences.lib ;
IN: factory.commands
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -72,4 +70,4 @@ drop
! { { [ dup empty? ] [ drop ] }
! { [ dup length 1 = ] [ drop maximize ] }
! { [ t ] [ tile-master* ] }
! { [ t ] [ tile-master* ] }

View File

@ -1,7 +1,7 @@
USING: help.syntax help.markup ;
IN: hash2
ARTICLE: { "hash2" "intro" }
ARTICLE: { "hash2" "intro" } "hash2 Vocabulary"
"The hash2 vocabulary specifies a simple minimal datastructure for hash tables with two integers as keys. These hash tables are fixed size and do not conform to the associative mapping protocol. Words used in creating and manipulating these hash tables include:"
{ $subsection <hash2> }
{ $subsection hash2 }

View File

@ -1,6 +1,5 @@
USING: arrays combinators.lib io io.streams.string
kernel math math.parser namespaces prettyprint
sequences splitting strings ascii ;
USING: arrays io io.streams.string kernel math math.parser namespaces
prettyprint sequences sequences.lib splitting strings ascii ;
IN: hexdump
<PRIVATE

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend kernel continuations namespaces sequences
assocs hashtables sorting arrays ;
assocs hashtables sorting arrays threads ;
IN: io.monitors
<PRIVATE
@ -17,7 +17,7 @@ TUPLE: monitor queue closed? ;
set-monitor-queue
} monitor construct ;
HOOK: fill-queue io-backend ( monitor -- )
GENERIC: fill-queue ( monitor -- )
: changed-file ( changed path -- )
namespace [ append ] change-at ;
@ -25,6 +25,39 @@ HOOK: fill-queue io-backend ( monitor -- )
: dequeue-change ( assoc -- path changes )
delete-any prune natural-sort >array ;
M: monitor dispose
dup check-monitor
t over set-monitor-closed?
delegate dispose ;
! Simple monitor; used on Linux and Mac OS X. On Windows,
! monitors are full-fledged ports.
TUPLE: simple-monitor handle callback ;
: <simple-monitor> ( handle -- simple-monitor )
f (monitor) {
set-simple-monitor-handle
set-delegate
} simple-monitor construct ;
: construct-simple-monitor ( handle class -- simple-monitor )
>r <simple-monitor> r> construct-delegate ; inline
: notify-callback ( simple-monitor -- )
dup simple-monitor-callback
f rot set-simple-monitor-callback
[ schedule-thread ] when* ;
M: simple-monitor fill-queue ( monitor -- )
dup simple-monitor-callback [
"Cannot wait for changes on the same file from multiple threads" throw
] when
[ swap set-simple-monitor-callback stop ] callcc0
check-monitor ;
M: simple-monitor dispose ( monitor -- )
dup delegate dispose notify-callback ;
PRIVATE>
HOOK: <monitor> io-backend ( path recursive? -- monitor )

View File

@ -1,24 +1,49 @@
USING: assocs io.files kernel namespaces sequences ;
USING: arrays assocs combinators.lib dlists io.files
kernel namespaces sequences shuffle vectors ;
IN: io.paths
: find-file ( seq str -- path/f )
[
[ path+ exists? ] curry find nip
] keep over [ path+ ] [ drop ] if ;
! HOOK: library-roots io-backend ( -- seq )
! HOOK: binary-roots io-backend ( -- seq )
<PRIVATE
: append-path ( path files -- paths )
[ path+ ] with map ;
[ >r path+ r> ] with* assoc-map ;
: get-paths ( dir -- paths )
dup directory keys append-path ;
dup directory append-path ;
: (walk-dir) ( path -- )
dup directory? [
get-paths dup % [ (walk-dir) ] each
first2 [
get-paths dup keys % [ (walk-dir) ] each
] [
drop
] if ;
PRIVATE>
: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ;
: walk-dir ( path -- seq )
dup directory? 2array [ (walk-dir) ] { } make ;
GENERIC# find-file* 1 ( obj quot -- path/f )
M: dlist find-file* ( dlist quot -- path/f )
over dlist-empty? [ 2drop f ] [
2dup >r pop-front get-paths dup r> assoc-find
[ drop 3nip ]
[ 2drop [ nip ] assoc-subset keys pick push-all-back find-file* ] if
] if ;
M: vector find-file* ( vector quot -- path/f )
over empty? [ 2drop f ] [
2dup >r pop get-paths dup r> assoc-find
[ drop 3nip ]
[ 2drop [ nip ] assoc-subset keys pick push-all find-file* ] if
] if ;
: prepare-find-file ( quot -- quot )
[ drop ] swap compose ;
: find-file-depth ( path quot -- path/f )
prepare-find-file >r 1vector r> find-file* ;
: find-file-breadth ( path quot -- path/f )
prepare-find-file >r 1dlist r> find-file* ;

View File

@ -5,14 +5,14 @@ USING: io.backend io.unix.backend io.unix.kqueue io.unix.select
io.launcher io.unix.launcher namespaces kernel assocs threads
continuations ;
! On *BSD and Mac OS X, we use select() for the top-level
! multiplexer, and we hang a kqueue off of it but file change
! notification and process exit notification.
! On Mac OS X, we use select() for the top-level
! multiplexer, and we hang a kqueue off of it for process exit
! notification.
! kqueue is buggy with files and ptys so we can't use it as the
! main multiplexer.
TUPLE: bsd-io ;
MIXIN: bsd-io
INSTANCE: bsd-io unix-io
@ -25,5 +25,3 @@ M: bsd-io init-io ( -- )
M: bsd-io register-process ( process -- )
process-handle kqueue-mx get-global add-pid-task ;
T{ bsd-io } set-io-backend

View File

@ -0,0 +1,8 @@
IN: io.unix.freebsd
USING: io.unix.bsd io.backend core-foundation.fsevents ;
TUPLE: freebsd-io ;
INSTANCE: freebsd-io bsd-io
T{ freebsd-io } set-io-backend

View File

@ -11,14 +11,10 @@ TUPLE: linux-io ;
INSTANCE: linux-io unix-io
TUPLE: linux-monitor path wd callback ;
TUPLE: linux-monitor ;
: <linux-monitor> ( path wd -- monitor )
f (monitor) {
set-linux-monitor-path
set-linux-monitor-wd
set-delegate
} linux-monitor construct ;
: <linux-monitor> ( wd -- monitor )
linux-monitor construct-simple-monitor ;
TUPLE: inotify watches ;
@ -42,34 +38,18 @@ TUPLE: inotify watches ;
] when ;
: add-watch ( path mask -- monitor )
dupd (add-watch)
dup check-existing
(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 ;
dup simple-monitor-handle watches delete-at
simple-monitor-handle 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 ;
dup delegate dispose remove-watch ;
: ?flag ( n mask symbol -- n )
pick rot bitand 0 > [ , ] [ drop ] if ;
@ -136,5 +116,3 @@ M: linux-io init-io ( -- )
T{ linux-io } set-io-backend
[ start-wait-thread ] "io.unix.linux" add-init-hook
"vocabs.monitor" require

View File

@ -0,0 +1,27 @@
IN: io.unix.macosx
USING: io.unix.bsd io.backend io.monitors io.monitors.private
continuations kernel core-foundation.fsevents sequences
namespaces arrays ;
TUPLE: macosx-io ;
INSTANCE: macosx-io bsd-io
T{ macosx-io } set-io-backend
TUPLE: macosx-monitor ;
: enqueue-notifications ( triples monitor -- )
tuck monitor-queue
[ [ first { +modify-file+ } swap changed-file ] each ] bind
notify-callback ;
M: macosx-io <monitor>
drop
f macosx-monitor construct-simple-monitor
dup [ enqueue-notifications ] curry
rot 1array 0 0 <event-stream>
over set-simple-monitor-handle ;
M: macosx-monitor dispose
dup simple-monitor-handle dispose delegate dispose ;

View File

@ -0,0 +1,8 @@
IN: io.unix.netbsd
USING: io.unix.bsd io.backend ;
TUPLE: netbsd-io ;
INSTANCE: netbsd-io bsd-io
T{ netbsd-io } set-io-backend

View File

@ -0,0 +1,8 @@
IN: io.unix.openbsd
USING: io.unix.bsd io.backend core-foundation.fsevents ;
TUPLE: openbsd-io ;
INSTANCE: openbsd-io bsd-io
T{ openbsd-io } set-io-backend

View File

@ -1,10 +1,7 @@
USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
io.unix.launcher io.unix.mmap io.backend combinators namespaces
system vocabs.loader ;
system vocabs.loader sequences ;
{
{ [ bsd? ] [ "io.unix.bsd" ] }
{ [ macosx? ] [ "io.unix.bsd" ] }
{ [ linux? ] [ "io.unix.linux" ] }
{ [ solaris? ] [ "io.unix.solaris" ] }
} cond require
"io.unix." os append require
"vocabs.monitor" require

View File

@ -78,7 +78,7 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero?
[ 2drop ] [ swap <displaced-alien> (changed-files) ] if ;
M: windows-nt-io fill-queue ( monitor -- )
M: win32-monitor fill-queue ( monitor -- )
dup buffer-ptr over read-changes
[ zero? [ drop ] [ (changed-files) ] if ] H{ } make-assoc
swap set-monitor-queue ;

View File

@ -12,5 +12,3 @@ USE: io.windows.mmap
USE: io.backend
T{ windows-nt-io } set-io-backend
"vocabs.monitor" require

View File

@ -1,5 +1,5 @@
USING: locals math sequences tools.test hashtables words kernel
namespaces ;
namespaces arrays ;
IN: temporary
:: foo | a b | a a ;
@ -35,6 +35,21 @@ IN: temporary
:: let-test-3 | |
[let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
:: let-test-4 | |
[let | a [ 1 ] b [ ] | a b 2array ] ;
[ { 1 2 } ] [ 2 let-test-4 ] unit-test
:: let-test-5 | |
[let | a [ ] b [ ] | a b 2array ] ;
[ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
:: let-test-6 | |
[let | a [ ] b [ 1 ] | a b 2array ] ;
[ { 2 1 } ] [ 2 let-test-6 ] unit-test
[ -1 ] [ -1 let-test-3 call ] unit-test
[ 5 ] [
@ -104,7 +119,6 @@ write-test-2 "q" set
SYMBOL: a
:: use-test | a b c |
USE: kernel
;
USE: kernel ;
[ t ] [ a symbol? ] unit-test

View File

@ -1,10 +1,10 @@
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences sequences.private assocs
math inference.transforms parser words quotations debugger
macros arrays macros splitting combinators prettyprint.backend
definitions prettyprint hashtables combinators.lib
prettyprint.sections ;
USING: kernel namespaces sequences sequences.private assocs math
inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend
definitions prettyprint hashtables combinators.lib
prettyprint.sections sequences.private ;
IN: locals
! Inspired by
@ -69,14 +69,14 @@ C: <quote> quote
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: localize-writer ( obj args -- quot )
>r "local-reader" word-prop r> read-local [ set-first ] append ;
>r "local-reader" word-prop r> read-local [ 0 swap set-array-nth ] append ;
: localize ( obj args -- quot )
{
{ [ over local? ] [ read-local ] }
{ [ over quote? ] [ >r quote-local r> read-local ] }
{ [ over local-word? ] [ read-local [ call ] append ] }
{ [ over local-reader? ] [ read-local [ first ] append ] }
{ [ over local-reader? ] [ read-local [ 0 swap array-nth ] append ] }
{ [ over local-writer? ] [ localize-writer ] }
{ [ over \ lambda eq? ] [ 2drop [ ] ] }
{ [ t ] [ drop 1quotation ] }
@ -138,34 +138,39 @@ M: quotation free-vars { } [ add-if-free ] reduce ;
M: lambda free-vars
dup lambda-vars swap lambda-body free-vars seq-diff ;
M: let free-vars
dup let-vars swap let-body free-vars seq-diff ;
M: wlet free-vars
dup wlet-vars swap wlet-body free-vars seq-diff ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! lambda-rewrite
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
GENERIC: lambda-rewrite* ( obj -- )
: lambda-rewrite [ lambda-rewrite* ] [ ] make ;
GENERIC: local-rewrite* ( obj -- )
UNION: block quotation lambda ;
: lambda-rewrite
[ local-rewrite* ] [ ] make
[ [ lambda-rewrite* ] each ] [ ] make ;
UNION: block callable lambda ;
GENERIC: block-vars ( block -- seq )
GENERIC: block-body ( block -- quot )
M: quotation block-vars drop { } ;
M: callable block-vars drop { } ;
M: quotation block-body ;
M: callable block-body ;
M: callable local-rewrite*
[ [ local-rewrite* ] each ] [ ] make , ;
M: lambda block-vars lambda-vars ;
M: lambda block-body lambda-body ;
M: lambda local-rewrite*
dup lambda-vars swap lambda-body
[ local-rewrite* \ call , ] [ ] make <lambda> , ;
M: block lambda-rewrite*
#! Turn free variables into bound variables, curry them
#! onto the body
@ -177,6 +182,8 @@ M: block lambda-rewrite*
M: object lambda-rewrite* , ;
M: object local-rewrite* , ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-locals ( seq -- words assoc )
@ -227,16 +234,17 @@ M: object lambda-rewrite* , ;
: parse-bindings ( -- alist )
scan "|" assert= [ (parse-bindings) ] { } make dup keys ;
: let-rewrite ( words body -- )
<lambda> lambda-rewrite* \ call , ;
M: let local-rewrite*
{ let-bindings let-vars let-body } get-slots -rot
[ <reversed> ] 2apply
[
1array -rot second -rot <lambda>
[ call ] curry compose
] 2each local-rewrite* \ call , ;
M: let lambda-rewrite*
dup let-bindings values [ lambda-rewrite* \ call , ] each
{ let-vars let-body } get-slots let-rewrite ;
M: wlet lambda-rewrite*
dup wlet-bindings values [ lambda-rewrite* ] each
{ wlet-vars wlet-body } get-slots let-rewrite ;
M: wlet local-rewrite*
dup wlet-bindings values over wlet-vars rot wlet-body
<lambda> [ call ] curry compose local-rewrite* \ call , ;
: (::) ( prop -- word quot n )
>r CREATE dup reset-generic

View File

@ -108,3 +108,12 @@ PRIVATE>
swap -1.0 * exp
*
] if ;
! James Stirling's approximation for N!:
! http://www.csse.monash.edu.au/~lloyd/tildeAlgDS/Numerical/Stirling/
: stirling-fact ( n -- fact )
[ pi 2 * * sqrt ]
[ dup e / swap ^ ]
[ 12 * recip 1 + ]
tri * * ;

0
extra/math/primes/list/authors.txt Executable file → Normal file
View File

File diff suppressed because it is too large Load Diff

View File

@ -1,5 +1,5 @@
USING: combinators.lib kernel math math.analysis
math.functions math.vectors sequences sequences.lib sorting ;
USING: kernel math math.analysis math.functions math.vectors sequences
sequences.lib sorting ;
IN: math.statistics
: mean ( seq -- n )
@ -43,9 +43,9 @@ IN: math.statistics
: ste ( seq -- x )
#! standard error, standard deviation / sqrt ( length of sequence )
dup std swap length sqrt / ;
: ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
! finds sigma((xi-mean(x))(yi-mean(y))
! finds sigma((xi-mean(x))(yi-mean(y))
0 [ [ >r pick r> swap - ] 2apply * + ] 2reduce 2nip ;
: (r) ( mean(x) mean(y) {x} {y} sx sy -- r )

View File

@ -19,7 +19,7 @@ IN: multiline
: STRING:
CREATE dup reset-generic
parse-here 1quotation define ; parsing
parse-here 1quotation define-inline ; parsing
: (parse-multiline-string) ( start-index end-text -- end-index )
lexer get lexer-line-text [

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
! TODO:
! TODO:
! based on number of channels in file.
! - End of decoding is indicated by an exception when reading the stream.
! How to work around this? C player example uses feof but streams don't
@ -14,27 +14,27 @@ USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays
sequences libc shuffle alien.c-types system openal math
namespaces threads shuffle opengl arrays ui.gadgets.worlds
combinators math.parser ui.gadgets ui.render opengl.gl ui
continuations io.files hints combinators.lib ;
continuations io.files hints combinators.lib sequences.lib ;
IN: ogg.player
: audio-buffer-size ( -- number ) 128 1024 * ; inline
: audio-buffer-size ( -- number ) 128 1024 * ; inline
TUPLE: player stream temp-state
op oy og
TUPLE: player stream temp-state
op oy og
vo vi vd vb vc vorbis
to ti tc td yuv rgb theora video-ready? video-time video-granulepos
source buffers buffer-indexes start-time
playing? audio-full? audio-index audio-buffer audio-granulepos
playing? audio-full? audio-index audio-buffer audio-granulepos
gadget ;
: init-vorbis ( player -- )
dup player-oy ogg_sync_init drop
dup player-vi vorbis_info_init
dup player-vi vorbis_info_init
player-vc vorbis_comment_init ;
: init-theora ( player -- )
dup player-ti theora_info_init
dup player-ti theora_info_init
player-tc theora_comment_init ;
: init-sound ( player -- )
@ -45,45 +45,45 @@ TUPLE: player stream temp-state
: <player> ( stream -- player )
{ set-player-stream } player construct
0 over set-player-vorbis
0 over set-player-theora
0 over set-player-video-time
0 over set-player-video-granulepos
0 over set-player-vorbis
0 over set-player-theora
0 over set-player-video-time
0 over set-player-video-granulepos
f over set-player-video-ready?
f over set-player-audio-full?
0 over set-player-audio-index
0 over set-player-start-time
0 over set-player-audio-index
0 over set-player-start-time
audio-buffer-size "short" <c-array> over set-player-audio-buffer
0 over set-player-audio-granulepos
f over set-player-playing?
"ogg_packet" malloc-object over set-player-op
"ogg_sync_state" malloc-object over set-player-oy
"ogg_sync_state" malloc-object over set-player-oy
"ogg_page" malloc-object over set-player-og
"ogg_stream_state" malloc-object over set-player-vo
"vorbis_info" malloc-object over set-player-vi
"vorbis_dsp_state" malloc-object over set-player-vd
"vorbis_block" malloc-object over set-player-vb
"vorbis_comment" malloc-object over set-player-vc
"vorbis_comment" malloc-object over set-player-vc
"ogg_stream_state" malloc-object over set-player-to
"theora_info" malloc-object over set-player-ti
"theora_comment" malloc-object over set-player-tc
"theora_state" malloc-object over set-player-td
"theora_state" malloc-object over set-player-td
"yuv_buffer" <c-object> over set-player-yuv
"ogg_stream_state" <c-object> over set-player-temp-state
dup init-sound
dup init-vorbis
dup init-vorbis
dup init-theora ;
: num-channels ( player -- channels )
player-vi vorbis_info-channels ;
: al-channel-format ( player -- format )
num-channels 1 = [ AL_FORMAT_MONO16 ] [ AL_FORMAT_STEREO16 ] if ;
: get-time ( player -- time )
dup player-start-time zero? [
millis over set-player-start-time
] when
] when
player-start-time millis swap - 1000.0 /f ;
: clamp ( n -- n )
@ -149,28 +149,28 @@ HINTS: yuv>rgb byte-array byte-array ;
dup player-gadget [
dup { player-td player-yuv } get-slots theora_decode_YUVout drop
dup player-rgb over player-yuv yuv>rgb
dup player-gadget find-world dup draw-world
dup player-gadget find-world dup draw-world
] when ;
: num-audio-buffers-processed ( player -- player n )
dup player-source AL_BUFFERS_PROCESSED 0 <uint>
dup player-source AL_BUFFERS_PROCESSED 0 <uint>
[ alGetSourcei check-error ] keep *uint ;
: append-new-audio-buffer ( player -- player )
dup player-buffers 1 gen-buffers append over set-player-buffers
dup player-buffers 1 gen-buffers append over set-player-buffers
[ [ player-buffers second ] keep al-channel-format ] keep
[ player-audio-buffer dup length ] keep
[ player-vi vorbis_info-rate alBufferData check-error ] keep
[ player-vi vorbis_info-rate alBufferData check-error ] keep
[ player-source 1 ] keep
[ player-buffers second <uint> alSourceQueueBuffers check-error ] keep ;
: fill-processed-audio-buffer ( player n -- player )
#! n is the number of audio buffers processed
#! n is the number of audio buffers processed
over >r >r dup player-source r> pick player-buffer-indexes
[ alSourceUnqueueBuffers check-error ] keep
*uint dup r> swap >r al-channel-format rot
[ alSourceUnqueueBuffers check-error ] keep
*uint dup r> swap >r al-channel-format rot
[ player-audio-buffer dup length ] keep
[ player-vi vorbis_info-rate alBufferData check-error ] keep
[ player-vi vorbis_info-rate alBufferData check-error ] keep
[ player-source 1 ] keep
r> <uint> swap >r alSourceQueueBuffers check-error r> ;
@ -179,12 +179,12 @@ HINTS: yuv>rgb byte-array byte-array ;
{ [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }
{ [ over player-buffers length 2 = over zero? and ] [ 0 sleep drop f ] }
{ [ t ] [ fill-processed-audio-buffer t ] }
} cond ;
} cond ;
: start-audio ( player -- player bool )
[ [ player-buffers first ] keep al-channel-format ] keep
[ player-audio-buffer dup length ] keep
[ player-vi vorbis_info-rate alBufferData check-error ] keep
[ player-vi vorbis_info-rate alBufferData check-error ] keep
[ player-source 1 ] keep
[ player-buffers first <uint> alSourceQueueBuffers check-error ] keep
[ player-source alSourcePlay check-error ] keep
@ -201,12 +201,12 @@ HINTS: yuv>rgb byte-array byte-array ;
: check-not-negative ( int -- )
0 < [ "Word result was a negative number." throw ] when ;
: buffer-size ( -- number )
: buffer-size ( -- number )
4096 ; inline
: sync-buffer ( player -- buffer size player )
[ player-oy buffer-size ogg_sync_buffer buffer-size ] keep ;
: stream-into-buffer ( buffer size player -- len player )
[ player-stream read-bytes-into ] keep ;
@ -217,23 +217,23 @@ HINTS: yuv>rgb byte-array byte-array ;
#! Take some compressed bitstream data and sync it for
#! page extraction.
sync-buffer stream-into-buffer confirm-buffer ;
: queue-page ( player -- player )
#! Push a page into the stream for packetization
[ { player-vo player-og } get-slots ogg_stream_pagein drop ] keep
[ { player-vo player-og } get-slots ogg_stream_pagein drop ] keep
[ { player-to player-og } get-slots ogg_stream_pagein drop ] keep ;
: retrieve-page ( player -- player bool )
#! Sync the streams and get a page. Return true if a page was
#! successfully retrieved.
dup { player-oy player-og } get-slots ogg_sync_pageout 0 > ;
dup { player-oy player-og } get-slots ogg_sync_pageout 0 > ;
: standard-initial-header? ( player -- player bool )
dup player-og ogg_page_bos zero? not ;
: ogg-stream-init ( player -- state player )
#! Init the encode/decode logical stream state
[ player-temp-state ] keep
[ player-temp-state ] keep
[ player-og ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ;
: ogg-stream-pagein ( state player -- state player )
@ -266,11 +266,11 @@ HINTS: yuv>rgb byte-array byte-array ;
: is-vorbis-packet? ( player -- player bool )
dup player-vorbis zero? [ vorbis-header? ] [ f ] if ;
: copy-to-vorbis-state ( state player -- player )
#! Copy the state to the vorbis state structure in the player
[ player-vo swap dup length memcpy ] keep ;
: handle-initial-vorbis-header ( state player -- player )
copy-to-vorbis-state 1 over set-player-vorbis ;
@ -293,16 +293,16 @@ HINTS: yuv>rgb byte-array byte-array ;
#! Parse Vorbis headers, ignoring any other type stored
#! in the Ogg container.
retrieve-page [
process-initial-header [
process-initial-header [
parse-initial-headers
] [
#! Don't leak the page, get it into the appropriate stream
queue-page
] if
] [
queue-page
] if
] [
buffer-data not [ parse-initial-headers ] when
] if ;
: have-required-vorbis-headers? ( player -- player bool )
#! Return true if we need to decode vorbis due to there being
#! vorbis headers read from the stream but we don't have them all
@ -350,17 +350,17 @@ HINTS: yuv>rgb byte-array byte-array ;
get-remaining-vorbis-header-packet [
decode-remaining-vorbis-header-packet
increment-vorbis-header-count
parse-remaining-vorbis-headers
] when
parse-remaining-vorbis-headers
] when
] when ;
: parse-remaining-theora-headers ( player -- player )
have-required-theora-headers? not [
get-remaining-theora-header-packet [
decode-remaining-theora-header-packet
decode-remaining-theora-header-packet
increment-theora-header-count
parse-remaining-theora-headers
] when
parse-remaining-theora-headers
] when
] when ;
: get-more-header-data ( player -- player )
@ -368,12 +368,12 @@ HINTS: yuv>rgb byte-array byte-array ;
: parse-remaining-headers ( player -- player )
have-required-vorbis-headers? not swap have-required-theora-headers? not swapd or [
parse-remaining-vorbis-headers
parse-remaining-vorbis-headers
parse-remaining-theora-headers
retrieve-page [ queue-page ] [ get-more-header-data ] if
parse-remaining-headers
] when ;
: tear-down-vorbis ( player -- player )
dup player-vi vorbis_info_clear
dup player-vc vorbis_comment_clear ;
@ -387,8 +387,8 @@ HINTS: yuv>rgb byte-array byte-array ;
dup { player-vd player-vb } get-slots vorbis_block_init drop ;
: init-theora-codec ( player -- player )
dup { player-td player-ti } get-slots theora_decode_init drop
dup player-ti theora_info-frame_width over player-ti theora_info-frame_height
dup { player-td player-ti } get-slots theora_decode_init drop
dup player-ti theora_info-frame_width over player-ti theora_info-frame_height
4 * * <byte-array> over set-player-rgb ;
@ -412,36 +412,36 @@ HINTS: yuv>rgb byte-array byte-array ;
"x" %
dup player-ti theora_info-height #
" " %
dup player-ti theora_info-fps_numerator
dup player-ti theora_info-fps_numerator
over player-ti theora_info-fps_denominator /f #
" fps video" %
] "" make print ;
: initialize-decoder ( player -- player )
dup player-vorbis zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if
dup player-vorbis zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if
dup player-theora zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ;
: sync-pages ( player -- player )
retrieve-page [
queue-page sync-pages
queue-page sync-pages
] when ;
: audio-buffer-not-ready? ( player -- player bool )
dup player-vorbis zero? not over player-audio-full? not and ;
: pending-decoded-audio? ( player -- player pcm len bool )
f <void*> 2dup >r player-vd r> vorbis_synthesis_pcmout dup 0 > ;
: buffer-space-available ( player -- available )
audio-buffer-size swap player-audio-index - ;
: samples-to-read ( player available len -- numread )
>r swap num-channels / r> min ;
: each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline
: each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline
: add-to-buffer ( player val -- )
over player-audio-index pick player-audio-buffer set-short-nth
over player-audio-index pick player-audio-buffer set-short-nth
dup player-audio-index 1+ swap set-player-audio-index ;
: get-audio-value ( pcm sample channel -- value )
@ -452,15 +452,15 @@ HINTS: yuv>rgb byte-array byte-array ;
: (process-sample) ( player pcm sample -- )
pick num-channels [ process-channels ] each-with3 ;
: process-samples ( player pcm numread -- )
[ (process-sample) ] each-with2 ;
: decode-pending-audio ( player pcm result -- player )
! [ "ret = " % dup # ] "" make write
pick [ buffer-space-available swap ] keep -rot samples-to-read
pick [ buffer-space-available swap ] keep -rot samples-to-read
pick over >r >r process-samples r> r> swap
! numread player
! numread player
dup player-audio-index audio-buffer-size = [
t over set-player-audio-full?
] when
@ -480,10 +480,10 @@ HINTS: yuv>rgb byte-array byte-array ;
dup { player-vb player-op } get-slots vorbis_synthesis 0 = [
dup { player-vd player-vb } get-slots vorbis_synthesis_blockin drop
] when
t
t
] [
#! Need more data. Break out to suck in another page.
f
f
] if ;
: decode-audio ( player -- player )
@ -504,13 +504,13 @@ HINTS: yuv>rgb byte-array byte-array ;
dup { player-to player-op } get-slots ogg_stream_packetout 0 > [
dup { player-td player-op } get-slots theora_decode_packetin drop
dup player-td theora_state-granulepos over set-player-video-granulepos
dup { player-td player-video-granulepos } get-slots theora_granule_time
dup { player-td player-video-granulepos } get-slots theora_granule_time
over set-player-video-time
t over set-player-video-ready?
decode-video
decode-video
] when
] when ;
: decode ( player -- player )
get-more-header-data sync-pages
decode-audio
@ -520,7 +520,7 @@ HINTS: yuv>rgb byte-array byte-array ;
f over set-player-audio-full?
0 over set-player-audio-index
] when
] when
] when
dup player-video-ready? [
dup player-video-time over get-time - dup 0.0 < [
-0.1 > [ process-video ] when
@ -539,7 +539,7 @@ HINTS: yuv>rgb byte-array byte-array ;
[ player-vi free ] keep
[ player-vd free ] keep
[ player-vb free ] keep
[ player-vc free ] keep
[ player-vc free ] keep
[ player-to free ] keep
[ player-ti free ] keep
[ player-tc free ] keep
@ -550,23 +550,23 @@ HINTS: yuv>rgb byte-array byte-array ;
[
num-audio-buffers-processed over player-source rot player-buffer-indexes swapd
alSourceUnqueueBuffers check-error
alSourceUnqueueBuffers check-error
] keep ;
: delete-openal-buffers ( player -- player )
[
[
player-buffers [
1 swap <uint> alDeleteBuffers check-error
] each
] each
] keep ;
: delete-openal-source ( player -- player )
[ player-source 1 swap <uint> alDeleteSources check-error ] keep ;
: cleanup ( player -- player )
free-malloced-objects
free-malloced-objects
unqueue-openal-buffers
delete-openal-buffers
delete-openal-buffers
delete-openal-source ;
: wait-for-sound ( player -- player )
@ -583,7 +583,7 @@ TUPLE: theora-gadget player ;
theora-gadget construct-gadget
[ set-theora-gadget-player ] keep ;
M: theora-gadget pref-dim*
M: theora-gadget pref-dim*
theora-gadget-player
player-ti dup theora_info-width swap theora_info-height 2array ;
@ -598,10 +598,10 @@ M: theora-gadget draw-gadget* ( gadget -- )
"Theora Player" open-window ;
: play-ogg ( player -- )
parse-initial-headers
parse-remaining-headers
initialize-decoder
dup player-gadget [ initialize-gui ] when*
parse-initial-headers
parse-remaining-headers
initialize-decoder
dup player-gadget [ initialize-gui ] when*
[ decode ] [ drop ] recover
! decode
wait-for-sound
@ -615,8 +615,8 @@ M: theora-gadget draw-gadget* ( gadget -- )
<file-reader> play-vorbis-stream ;
: play-theora-stream ( stream -- )
<player>
dup <theora-gadget> over set-player-gadget
<player>
dup <theora-gadget> over set-player-gadget
play-ogg ;
: play-theora-file ( filename -- )

View File

@ -0,0 +1,46 @@
USING: alien alien.syntax combinators kernel parser sequences
system words namespaces hashtables init math arrays assocs
sequences.lib continuations ;
<< {
{ [ windows? ] [ "opengl.gl.windows" ] }
{ [ macosx? ] [ "opengl.gl.macosx" ] }
{ [ unix? ] [ "opengl.gl.unix" ] }
{ [ t ] [ "Unknown OpenGL platform" throw ] }
} cond use+ >>
IN: opengl.gl.extensions
SYMBOL: +gl-function-number-counter+
SYMBOL: +gl-function-pointers+
: reset-gl-function-number-counter ( -- )
0 +gl-function-number-counter+ set-global ;
: reset-gl-function-pointers ( -- )
100 <hashtable> +gl-function-pointers+ set-global ;
[ reset-gl-function-pointers ] "opengl.gl init hook" add-init-hook
reset-gl-function-pointers
reset-gl-function-number-counter
: gl-function-number ( -- n )
+gl-function-number-counter+ get-global
dup 1+ +gl-function-number-counter+ set-global ;
: gl-function-pointer ( names n -- funptr )
gl-function-context 2array dup +gl-function-pointers+ get-global at
[ 2nip ] [
>r [ gl-function-address ] attempt-each
dup [ "OpenGL function not available" throw ] unless
dup r>
+gl-function-pointers+ get-global set-at
] if* ;
: GL-FUNCTION:
gl-function-calling-convention
scan
scan dup
scan drop "}" parse-tokens swap add*
gl-function-number
[ gl-function-pointer ] 2curry swap
";" parse-tokens [ "()" subseq? not ] subset
define-indirect
; parsing

View File

@ -3,8 +3,8 @@
! This file is based on the gl.h that comes with xorg-x11 6.8.2
USING: alien alien.syntax kernel parser sequences system words ;
<< windows? "opengl.gl.windows" "opengl.gl.unix" ? use+ >>
USING: alien alien.syntax combinators kernel parser sequences
system words opengl.gl.extensions ;
IN: opengl.gl
@ -1119,16 +1119,10 @@ FUNCTION: void glLoadName ( GLuint name ) ;
FUNCTION: void glPushName ( GLuint name ) ;
FUNCTION: void glPopName ( ) ;
! OpenGL extension functions
<< reset-gl-function-number-counter >>
! OpenGL 1.2
: GL_SMOOTH_POINT_SIZE_RANGE HEX: 0B12 ; inline
: GL_SMOOTH_POINT_SIZE_GRANULARITY HEX: 0B13 ; inline
: GL_SMOOTH_LINE_WIDTH_RANGE HEX: 0B22 ; inline
@ -1171,10 +1165,10 @@ FUNCTION: void glPopName ( ) ;
: GL_ALIASED_POINT_SIZE_RANGE HEX: 846D ; inline
: GL_ALIASED_LINE_WIDTH_RANGE HEX: 846E ; inline
GL-FUNCTION: void glCopyTexSubImage3D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLint x, GLint y, GLsizei width, GLsizei height ) ;
GL-FUNCTION: void glDrawRangeElements ( GLenum mode, GLuint start, GLuint end, GLsizei count, GLenum type, GLvoid* indices ) ;
GL-FUNCTION: void glTexImage3D ( GLenum target, GLint level, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLint border, GLenum format, GLenum type, GLvoid* pixels ) ;
GL-FUNCTION: void glTexSubImage3D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, GLvoid* pixels ) ;
GL-FUNCTION: void glCopyTexSubImage3D { glCopyTexSubImage3DEXT } ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLint x, GLint y, GLsizei width, GLsizei height ) ;
GL-FUNCTION: void glDrawRangeElements { glDrawRangeElementsEXT } ( GLenum mode, GLuint start, GLuint end, GLsizei count, GLenum type, GLvoid* indices ) ;
GL-FUNCTION: void glTexImage3D { glTexImage3DEXT } ( GLenum target, GLint level, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLint border, GLenum format, GLenum type, GLvoid* pixels ) ;
GL-FUNCTION: void glTexSubImage3D { glTexSubImage3DEXT } ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, GLvoid* pixels ) ;
! OpenGL 1.3
@ -1277,52 +1271,52 @@ GL-FUNCTION: void glTexSubImage3D ( GLenum target, GLint level, GLint xoffset, G
: GL_DOT3_RGBA HEX: 86AF ; inline
: GL_MULTISAMPLE_BIT HEX: 20000000 ; inline
GL-FUNCTION: void glActiveTexture ( GLenum texture ) ;
GL-FUNCTION: void glClientActiveTexture ( GLenum texture ) ;
GL-FUNCTION: void glCompressedTexImage1D ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLint border, GLsizei imageSize, GLvoid* data ) ;
GL-FUNCTION: void glCompressedTexImage2D ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLsizei height, GLint border, GLsizei imageSize, GLvoid* data ) ;
GL-FUNCTION: void glCompressedTexImage3D ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLsizei height, GLsizei depth, GLint border, GLsizei imageSize, GLvoid* data ) ;
GL-FUNCTION: void glCompressedTexSubImage1D ( GLenum target, GLint level, GLint xoffset, GLsizei width, GLenum format, GLsizei imageSize, GLvoid* data ) ;
GL-FUNCTION: void glCompressedTexSubImage2D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLsizei width, GLsizei height, GLenum format, GLsizei imageSize, GLvoid* data ) ;
GL-FUNCTION: void glCompressedTexSubImage3D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLsizei imageSize, GLvoid* data ) ;
GL-FUNCTION: void glGetCompressedTexImage ( GLenum target, GLint lod, GLvoid* img ) ;
GL-FUNCTION: void glLoadTransposeMatrixd ( GLdouble m[16] ) ;
GL-FUNCTION: void glLoadTransposeMatrixf ( GLfloat m[16] ) ;
GL-FUNCTION: void glMultTransposeMatrixd ( GLdouble m[16] ) ;
GL-FUNCTION: void glMultTransposeMatrixf ( GLfloat m[16] ) ;
GL-FUNCTION: void glMultiTexCoord1d ( GLenum target, GLdouble s ) ;
GL-FUNCTION: void glMultiTexCoord1dv ( GLenum target, GLdouble* v ) ;
GL-FUNCTION: void glMultiTexCoord1f ( GLenum target, GLfloat s ) ;
GL-FUNCTION: void glMultiTexCoord1fv ( GLenum target, GLfloat* v ) ;
GL-FUNCTION: void glMultiTexCoord1i ( GLenum target, GLint s ) ;
GL-FUNCTION: void glMultiTexCoord1iv ( GLenum target, GLint* v ) ;
GL-FUNCTION: void glMultiTexCoord1s ( GLenum target, GLshort s ) ;
GL-FUNCTION: void glMultiTexCoord1sv ( GLenum target, GLshort* v ) ;
GL-FUNCTION: void glMultiTexCoord2d ( GLenum target, GLdouble s, GLdouble t ) ;
GL-FUNCTION: void glMultiTexCoord2dv ( GLenum target, GLdouble* v ) ;
GL-FUNCTION: void glMultiTexCoord2f ( GLenum target, GLfloat s, GLfloat t ) ;
GL-FUNCTION: void glMultiTexCoord2fv ( GLenum target, GLfloat* v ) ;
GL-FUNCTION: void glMultiTexCoord2i ( GLenum target, GLint s, GLint t ) ;
GL-FUNCTION: void glMultiTexCoord2iv ( GLenum target, GLint* v ) ;
GL-FUNCTION: void glMultiTexCoord2s ( GLenum target, GLshort s, GLshort t ) ;
GL-FUNCTION: void glMultiTexCoord2sv ( GLenum target, GLshort* v ) ;
GL-FUNCTION: void glMultiTexCoord3d ( GLenum target, GLdouble s, GLdouble t, GLdouble r ) ;
GL-FUNCTION: void glMultiTexCoord3dv ( GLenum target, GLdouble* v ) ;
GL-FUNCTION: void glMultiTexCoord3f ( GLenum target, GLfloat s, GLfloat t, GLfloat r ) ;
GL-FUNCTION: void glMultiTexCoord3fv ( GLenum target, GLfloat* v ) ;
GL-FUNCTION: void glMultiTexCoord3i ( GLenum target, GLint s, GLint t, GLint r ) ;
GL-FUNCTION: void glMultiTexCoord3iv ( GLenum target, GLint* v ) ;
GL-FUNCTION: void glMultiTexCoord3s ( GLenum target, GLshort s, GLshort t, GLshort r ) ;
GL-FUNCTION: void glMultiTexCoord3sv ( GLenum target, GLshort* v ) ;
GL-FUNCTION: void glMultiTexCoord4d ( GLenum target, GLdouble s, GLdouble t, GLdouble r, GLdouble q ) ;
GL-FUNCTION: void glMultiTexCoord4dv ( GLenum target, GLdouble* v ) ;
GL-FUNCTION: void glMultiTexCoord4f ( GLenum target, GLfloat s, GLfloat t, GLfloat r, GLfloat q ) ;
GL-FUNCTION: void glMultiTexCoord4fv ( GLenum target, GLfloat* v ) ;
GL-FUNCTION: void glMultiTexCoord4i ( GLenum target, GLint s, GLint t, GLint r, GLint q ) ;
GL-FUNCTION: void glMultiTexCoord4iv ( GLenum target, GLint* v ) ;
GL-FUNCTION: void glMultiTexCoord4s ( GLenum target, GLshort s, GLshort t, GLshort r, GLshort q ) ;
GL-FUNCTION: void glMultiTexCoord4sv ( GLenum target, GLshort* v ) ;
GL-FUNCTION: void glSampleCoverage ( GLclampf value, GLboolean invert ) ;
GL-FUNCTION: void glActiveTexture { glActiveTextureARB } ( GLenum texture ) ;
GL-FUNCTION: void glClientActiveTexture { glClientActiveTextureARB } ( GLenum texture ) ;
GL-FUNCTION: void glCompressedTexImage1D { glCompressedTexImage1DARB } ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLint border, GLsizei imageSize, GLvoid* data ) ;
GL-FUNCTION: void glCompressedTexImage2D { glCompressedTexImage2DARB } ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLsizei height, GLint border, GLsizei imageSize, GLvoid* data ) ;
GL-FUNCTION: void glCompressedTexImage3D { glCompressedTexImage2DARB } ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLsizei height, GLsizei depth, GLint border, GLsizei imageSize, GLvoid* data ) ;
GL-FUNCTION: void glCompressedTexSubImage1D { glCompressedTexSubImage1DARB } ( GLenum target, GLint level, GLint xoffset, GLsizei width, GLenum format, GLsizei imageSize, GLvoid* data ) ;
GL-FUNCTION: void glCompressedTexSubImage2D { glCompressedTexSubImage2DARB } ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLsizei width, GLsizei height, GLenum format, GLsizei imageSize, GLvoid* data ) ;
GL-FUNCTION: void glCompressedTexSubImage3D { glCompressedTexSubImage3DARB } ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLsizei imageSize, GLvoid* data ) ;
GL-FUNCTION: void glGetCompressedTexImage { glGetCompressedTexImageARB } ( GLenum target, GLint lod, GLvoid* img ) ;
GL-FUNCTION: void glLoadTransposeMatrixd { glLoadTransposeMatrixdARB } ( GLdouble m[16] ) ;
GL-FUNCTION: void glLoadTransposeMatrixf { glLoadTransposeMatrixfARB } ( GLfloat m[16] ) ;
GL-FUNCTION: void glMultTransposeMatrixd { glMultTransposeMatrixdARB } ( GLdouble m[16] ) ;
GL-FUNCTION: void glMultTransposeMatrixf { glMultTransposeMatrixfARB } ( GLfloat m[16] ) ;
GL-FUNCTION: void glMultiTexCoord1d { glMultiTexCoord1dARB } ( GLenum target, GLdouble s ) ;
GL-FUNCTION: void glMultiTexCoord1dv { glMultiTexCoord1dvARB } ( GLenum target, GLdouble* v ) ;
GL-FUNCTION: void glMultiTexCoord1f { glMultiTexCoord1fARB } ( GLenum target, GLfloat s ) ;
GL-FUNCTION: void glMultiTexCoord1fv { glMultiTexCoord1fvARB } ( GLenum target, GLfloat* v ) ;
GL-FUNCTION: void glMultiTexCoord1i { glMultiTexCoord1iARB } ( GLenum target, GLint s ) ;
GL-FUNCTION: void glMultiTexCoord1iv { glMultiTexCoord1ivARB } ( GLenum target, GLint* v ) ;
GL-FUNCTION: void glMultiTexCoord1s { glMultiTexCoord1sARB } ( GLenum target, GLshort s ) ;
GL-FUNCTION: void glMultiTexCoord1sv { glMultiTexCoord1svARB } ( GLenum target, GLshort* v ) ;
GL-FUNCTION: void glMultiTexCoord2d { glMultiTexCoord2dARB } ( GLenum target, GLdouble s, GLdouble t ) ;
GL-FUNCTION: void glMultiTexCoord2dv { glMultiTexCoord2dvARB } ( GLenum target, GLdouble* v ) ;
GL-FUNCTION: void glMultiTexCoord2f { glMultiTexCoord2fARB } ( GLenum target, GLfloat s, GLfloat t ) ;
GL-FUNCTION: void glMultiTexCoord2fv { glMultiTexCoord2fvARB } ( GLenum target, GLfloat* v ) ;
GL-FUNCTION: void glMultiTexCoord2i { glMultiTexCoord2iARB } ( GLenum target, GLint s, GLint t ) ;
GL-FUNCTION: void glMultiTexCoord2iv { glMultiTexCoord2ivARB } ( GLenum target, GLint* v ) ;
GL-FUNCTION: void glMultiTexCoord2s { glMultiTexCoord2sARB } ( GLenum target, GLshort s, GLshort t ) ;
GL-FUNCTION: void glMultiTexCoord2sv { glMultiTexCoord2svARB } ( GLenum target, GLshort* v ) ;
GL-FUNCTION: void glMultiTexCoord3d { glMultiTexCoord3dARB } ( GLenum target, GLdouble s, GLdouble t, GLdouble r ) ;
GL-FUNCTION: void glMultiTexCoord3dv { glMultiTexCoord3dvARB } ( GLenum target, GLdouble* v ) ;
GL-FUNCTION: void glMultiTexCoord3f { glMultiTexCoord3fARB } ( GLenum target, GLfloat s, GLfloat t, GLfloat r ) ;
GL-FUNCTION: void glMultiTexCoord3fv { glMultiTexCoord3fvARB } ( GLenum target, GLfloat* v ) ;
GL-FUNCTION: void glMultiTexCoord3i { glMultiTexCoord3iARB } ( GLenum target, GLint s, GLint t, GLint r ) ;
GL-FUNCTION: void glMultiTexCoord3iv { glMultiTexCoord3ivARB } ( GLenum target, GLint* v ) ;
GL-FUNCTION: void glMultiTexCoord3s { glMultiTexCoord3sARB } ( GLenum target, GLshort s, GLshort t, GLshort r ) ;
GL-FUNCTION: void glMultiTexCoord3sv { glMultiTexCoord3svARB } ( GLenum target, GLshort* v ) ;
GL-FUNCTION: void glMultiTexCoord4d { glMultiTexCoord4dARB } ( GLenum target, GLdouble s, GLdouble t, GLdouble r, GLdouble q ) ;
GL-FUNCTION: void glMultiTexCoord4dv { glMultiTexCoord4dvARB } ( GLenum target, GLdouble* v ) ;
GL-FUNCTION: void glMultiTexCoord4f { glMultiTexCoord4fARB } ( GLenum target, GLfloat s, GLfloat t, GLfloat r, GLfloat q ) ;
GL-FUNCTION: void glMultiTexCoord4fv { glMultiTexCoord4fvARB } ( GLenum target, GLfloat* v ) ;
GL-FUNCTION: void glMultiTexCoord4i { glMultiTexCoord4iARB } ( GLenum target, GLint s, GLint t, GLint r, GLint q ) ;
GL-FUNCTION: void glMultiTexCoord4iv { glMultiTexCoord4ivARB } ( GLenum target, GLint* v ) ;
GL-FUNCTION: void glMultiTexCoord4s { glMultiTexCoord4sARB } ( GLenum target, GLshort s, GLshort t, GLshort r, GLshort q ) ;
GL-FUNCTION: void glMultiTexCoord4sv { glMultiTexCoord4svARB } ( GLenum target, GLshort* v ) ;
GL-FUNCTION: void glSampleCoverage { glSampleCoverageARB } ( GLclampf value, GLboolean invert ) ;
! OpenGL 1.4
@ -1368,52 +1362,51 @@ GL-FUNCTION: void glSampleCoverage ( GLclampf value, GLboolean invert ) ;
: GL_TEXTURE_COMPARE_FUNC HEX: 884D ; inline
: GL_COMPARE_R_TO_TEXTURE HEX: 884E ; inline
GL-FUNCTION: void glBlendColor ( GLclampf red, GLclampf green, GLclampf blue, GLclampf alpha ) ;
GL-FUNCTION: void glBlendEquation ( GLenum mode ) ;
GL-FUNCTION: void glBlendFuncSeparate ( GLenum sfactorRGB, GLenum dfactorRGB, GLenum sfactorAlpha, GLenum dfactorAlpha ) ;
GL-FUNCTION: void glFogCoordPointer ( GLenum type, GLsizei stride, GLvoid* pointer ) ;
GL-FUNCTION: void glFogCoordd ( GLdouble coord ) ;
GL-FUNCTION: void glFogCoorddv ( GLdouble* coord ) ;
GL-FUNCTION: void glFogCoordf ( GLfloat coord ) ;
GL-FUNCTION: void glFogCoordfv ( GLfloat* coord ) ;
GL-FUNCTION: void glMultiDrawArrays ( GLenum mode, GLint* first, GLsizei* count, GLsizei primcount ) ;
GL-FUNCTION: void glMultiDrawElements ( GLenum mode, GLsizei* count, GLenum type, GLvoid** indices, GLsizei primcount ) ;
GL-FUNCTION: void glPointParameterf ( GLenum pname, GLfloat param ) ;
GL-FUNCTION: void glPointParameterfv ( GLenum pname, GLfloat* params ) ;
GL-FUNCTION: void glSecondaryColor3b ( GLbyte red, GLbyte green, GLbyte blue ) ;
GL-FUNCTION: void glSecondaryColor3bv ( GLbyte* v ) ;
GL-FUNCTION: void glSecondaryColor3d ( GLdouble red, GLdouble green, GLdouble blue ) ;
GL-FUNCTION: void glSecondaryColor3dv ( GLdouble* v ) ;
GL-FUNCTION: void glSecondaryColor3f ( GLfloat red, GLfloat green, GLfloat blue ) ;
GL-FUNCTION: void glSecondaryColor3fv ( GLfloat* v ) ;
GL-FUNCTION: void glSecondaryColor3i ( GLint red, GLint green, GLint blue ) ;
GL-FUNCTION: void glSecondaryColor3iv ( GLint* v ) ;
GL-FUNCTION: void glSecondaryColor3s ( GLshort red, GLshort green, GLshort blue ) ;
GL-FUNCTION: void glSecondaryColor3sv ( GLshort* v ) ;
GL-FUNCTION: void glSecondaryColor3ub ( GLubyte red, GLubyte green, GLubyte blue ) ;
GL-FUNCTION: void glSecondaryColor3ubv ( GLubyte* v ) ;
GL-FUNCTION: void glSecondaryColor3ui ( GLuint red, GLuint green, GLuint blue ) ;
GL-FUNCTION: void glSecondaryColor3uiv ( GLuint* v ) ;
GL-FUNCTION: void glSecondaryColor3us ( GLushort red, GLushort green, GLushort blue ) ;
GL-FUNCTION: void glSecondaryColor3usv ( GLushort* v ) ;
GL-FUNCTION: void glSecondaryColorPointer ( GLint size, GLenum type, GLsizei stride, GLvoid* pointer ) ;
GL-FUNCTION: void glWindowPos2d ( GLdouble x, GLdouble y ) ;
GL-FUNCTION: void glWindowPos2dv ( GLdouble* p ) ;
GL-FUNCTION: void glWindowPos2f ( GLfloat x, GLfloat y ) ;
GL-FUNCTION: void glWindowPos2fv ( GLfloat* p ) ;
GL-FUNCTION: void glWindowPos2i ( GLint x, GLint y ) ;
GL-FUNCTION: void glWindowPos2iv ( GLint* p ) ;
GL-FUNCTION: void glWindowPos2s ( GLshort x, GLshort y ) ;
GL-FUNCTION: void glWindowPos2sv ( GLshort* p ) ;
GL-FUNCTION: void glWindowPos3d ( GLdouble x, GLdouble y, GLdouble z ) ;
GL-FUNCTION: void glWindowPos3dv ( GLdouble* p ) ;
GL-FUNCTION: void glWindowPos3f ( GLfloat x, GLfloat y, GLfloat z ) ;
GL-FUNCTION: void glWindowPos3fv ( GLfloat* p ) ;
GL-FUNCTION: void glWindowPos3i ( GLint x, GLint y, GLint z ) ;
GL-FUNCTION: void glWindowPos3iv ( GLint* p ) ;
GL-FUNCTION: void glWindowPos3s ( GLshort x, GLshort y, GLshort z ) ;
GL-FUNCTION: void glWindowPos3sv ( GLshort* p ) ;
GL-FUNCTION: void glBlendColor { glBlendColorEXT } ( GLclampf red, GLclampf green, GLclampf blue, GLclampf alpha ) ;
GL-FUNCTION: void glBlendEquation { glBlendEquationEXT } ( GLenum mode ) ;
GL-FUNCTION: void glBlendFuncSeparate { glBlendFuncSeparateEXT } ( GLenum sfactorRGB, GLenum dfactorRGB, GLenum sfactorAlpha, GLenum dfactorAlpha ) ;
GL-FUNCTION: void glFogCoordPointer { glFogCoordPointerEXT } ( GLenum type, GLsizei stride, GLvoid* pointer ) ;
GL-FUNCTION: void glFogCoordd { glFogCoorddEXT } ( GLdouble coord ) ;
GL-FUNCTION: void glFogCoorddv { glFogCoorddvEXT } ( GLdouble* coord ) ;
GL-FUNCTION: void glFogCoordf { glFogCoordfEXT } ( GLfloat coord ) ;
GL-FUNCTION: void glFogCoordfv { glFogCoordfvEXT } ( GLfloat* coord ) ;
GL-FUNCTION: void glMultiDrawArrays { glMultiDrawArraysEXT } ( GLenum mode, GLint* first, GLsizei* count, GLsizei primcount ) ;
GL-FUNCTION: void glMultiDrawElements { glMultiDrawElementsEXT } ( GLenum mode, GLsizei* count, GLenum type, GLvoid** indices, GLsizei primcount ) ;
GL-FUNCTION: void glPointParameterf { glPointParameterfARB } ( GLenum pname, GLfloat param ) ;
GL-FUNCTION: void glPointParameterfv { glPointParameterfvARB } ( GLenum pname, GLfloat* params ) ;
GL-FUNCTION: void glSecondaryColor3b { glSecondaryColor3bEXT } ( GLbyte red, GLbyte green, GLbyte blue ) ;
GL-FUNCTION: void glSecondaryColor3bv { glSecondaryColor3bvEXT } ( GLbyte* v ) ;
GL-FUNCTION: void glSecondaryColor3d { glSecondaryColor3dEXT } ( GLdouble red, GLdouble green, GLdouble blue ) ;
GL-FUNCTION: void glSecondaryColor3dv { glSecondaryColor3dvEXT } ( GLdouble* v ) ;
GL-FUNCTION: void glSecondaryColor3f { glSecondaryColor3fEXT } ( GLfloat red, GLfloat green, GLfloat blue ) ;
GL-FUNCTION: void glSecondaryColor3fv { glSecondaryColor3fvEXT } ( GLfloat* v ) ;
GL-FUNCTION: void glSecondaryColor3i { glSecondaryColor3iEXT } ( GLint red, GLint green, GLint blue ) ;
GL-FUNCTION: void glSecondaryColor3iv { glSecondaryColor3ivEXT } ( GLint* v ) ;
GL-FUNCTION: void glSecondaryColor3s { glSecondaryColor3sEXT } ( GLshort red, GLshort green, GLshort blue ) ;
GL-FUNCTION: void glSecondaryColor3sv { glSecondaryColor3svEXT } ( GLshort* v ) ;
GL-FUNCTION: void glSecondaryColor3ub { glSecondaryColor3ubEXT } ( GLubyte red, GLubyte green, GLubyte blue ) ;
GL-FUNCTION: void glSecondaryColor3ubv { glSecondaryColor3ubvEXT } ( GLubyte* v ) ;
GL-FUNCTION: void glSecondaryColor3ui { glSecondaryColor3uiEXT } ( GLuint red, GLuint green, GLuint blue ) ;
GL-FUNCTION: void glSecondaryColor3uiv { glSecondaryColor3uivEXT } ( GLuint* v ) ;
GL-FUNCTION: void glSecondaryColor3us { glSecondaryColor3usEXT } ( GLushort red, GLushort green, GLushort blue ) ;
GL-FUNCTION: void glSecondaryColor3usv { glSecondaryColor3usvEXT } ( GLushort* v ) ;
GL-FUNCTION: void glSecondaryColorPointer { glSecondaryColorPointerEXT } ( GLint size, GLenum type, GLsizei stride, GLvoid* pointer ) ;
GL-FUNCTION: void glWindowPos2d { glWindowPos2dARB } ( GLdouble x, GLdouble y ) ;
GL-FUNCTION: void glWindowPos2dv { glWindowPos2dvARB } ( GLdouble* p ) ;
GL-FUNCTION: void glWindowPos2f { glWindowPos2fARB } ( GLfloat x, GLfloat y ) ;
GL-FUNCTION: void glWindowPos2fv { glWindowPos2fvARB } ( GLfloat* p ) ;
GL-FUNCTION: void glWindowPos2i { glWindowPos2iARB } ( GLint x, GLint y ) ;
GL-FUNCTION: void glWindowPos2iv { glWindowPos2ivARB } ( GLint* p ) ;
GL-FUNCTION: void glWindowPos2s { glWindowPos2sARB } ( GLshort x, GLshort y ) ;
GL-FUNCTION: void glWindowPos2sv { glWindowPos2svARB } ( GLshort* p ) ;
GL-FUNCTION: void glWindowPos3d { glWindowPos3dARB } ( GLdouble x, GLdouble y, GLdouble z ) ;
GL-FUNCTION: void glWindowPos3dv { glWindowPos3dvARB } ( GLdouble* p ) ;
GL-FUNCTION: void glWindowPos3f { glWindowPos3fARB } ( GLfloat x, GLfloat y, GLfloat z ) ;
GL-FUNCTION: void glWindowPos3fv { glWindowPos3fvARB } ( GLfloat* p ) ;
GL-FUNCTION: void glWindowPos3i { glWindowPos3iARB } ( GLint x, GLint y, GLint z ) ;
GL-FUNCTION: void glWindowPos3iv { glWindowPos3ivARB } ( GLint* p ) ;
GL-FUNCTION: void glWindowPos3s { glWindowPos3sARB } ( GLshort x, GLshort y, GLshort z ) ;
GL-FUNCTION: void glWindowPos3sv { glWindowPos3svARB } ( GLshort* p ) ;
! OpenGL 1.5
@ -1471,25 +1464,25 @@ GL-FUNCTION: void glWindowPos3sv ( GLshort* p ) ;
TYPEDEF: ptrdiff_t GLsizeiptr
TYPEDEF: ptrdiff_t GLintptr
GL-FUNCTION: void glBeginQuery ( GLenum target, GLuint id ) ;
GL-FUNCTION: void glBindBuffer ( GLenum target, GLuint buffer ) ;
GL-FUNCTION: void glBufferData ( GLenum target, GLsizeiptr size, GLvoid* data, GLenum usage ) ;
GL-FUNCTION: void glBufferSubData ( GLenum target, GLintptr offset, GLsizeiptr size, GLvoid* data ) ;
GL-FUNCTION: void glDeleteBuffers ( GLsizei n, GLuint* buffers ) ;
GL-FUNCTION: void glDeleteQueries ( GLsizei n, GLuint* ids ) ;
GL-FUNCTION: void glEndQuery ( GLenum target ) ;
GL-FUNCTION: void glGenBuffers ( GLsizei n, GLuint* buffers ) ;
GL-FUNCTION: void glGenQueries ( GLsizei n, GLuint* ids ) ;
GL-FUNCTION: void glGetBufferParameteriv ( GLenum target, GLenum pname, GLint* params ) ;
GL-FUNCTION: void glGetBufferPointerv ( GLenum target, GLenum pname, GLvoid** params ) ;
GL-FUNCTION: void glGetBufferSubData ( GLenum target, GLintptr offset, GLsizeiptr size, GLvoid* data ) ;
GL-FUNCTION: void glGetQueryObjectiv ( GLuint id, GLenum pname, GLint* params ) ;
GL-FUNCTION: void glGetQueryObjectuiv ( GLuint id, GLenum pname, GLuint* params ) ;
GL-FUNCTION: void glGetQueryiv ( GLenum target, GLenum pname, GLint* params ) ;
GL-FUNCTION: GLboolean glIsBuffer ( GLuint buffer ) ;
GL-FUNCTION: GLboolean glIsQuery ( GLuint id ) ;
GL-FUNCTION: GLvoid* glMapBuffer ( GLenum target, GLenum access ) ;
GL-FUNCTION: GLboolean glUnmapBuffer ( GLenum target ) ;
GL-FUNCTION: void glBeginQuery { glBeginQueryARB } ( GLenum target, GLuint id ) ;
GL-FUNCTION: void glBindBuffer { glBindBufferARB } ( GLenum target, GLuint buffer ) ;
GL-FUNCTION: void glBufferData { glBufferDataARB } ( GLenum target, GLsizeiptr size, GLvoid* data, GLenum usage ) ;
GL-FUNCTION: void glBufferSubData { glBufferSubDataARB } ( GLenum target, GLintptr offset, GLsizeiptr size, GLvoid* data ) ;
GL-FUNCTION: void glDeleteBuffers { glDeleteBuffersARB } ( GLsizei n, GLuint* buffers ) ;
GL-FUNCTION: void glDeleteQueries { glDeleteQueriesARB } ( GLsizei n, GLuint* ids ) ;
GL-FUNCTION: void glEndQuery { glEndQueryARB } ( GLenum target ) ;
GL-FUNCTION: void glGenBuffers { glGenBuffersARB } ( GLsizei n, GLuint* buffers ) ;
GL-FUNCTION: void glGenQueries { glGenQueriesARB } ( GLsizei n, GLuint* ids ) ;
GL-FUNCTION: void glGetBufferParameteriv { glGetBufferParameterivARB } ( GLenum target, GLenum pname, GLint* params ) ;
GL-FUNCTION: void glGetBufferPointerv { glGetBufferPointervARB } ( GLenum target, GLenum pname, GLvoid** params ) ;
GL-FUNCTION: void glGetBufferSubData { glGetBufferSubDataARB } ( GLenum target, GLintptr offset, GLsizeiptr size, GLvoid* data ) ;
GL-FUNCTION: void glGetQueryObjectiv { glGetQueryObjectivARB } ( GLuint id, GLenum pname, GLint* params ) ;
GL-FUNCTION: void glGetQueryObjectuiv { glGetQueryObjectuivARB } ( GLuint id, GLenum pname, GLuint* params ) ;
GL-FUNCTION: void glGetQueryiv { glGetQueryivARB } ( GLenum target, GLenum pname, GLint* params ) ;
GL-FUNCTION: GLboolean glIsBuffer { glIsBufferARB } ( GLuint buffer ) ;
GL-FUNCTION: GLboolean glIsQuery { glIsQueryARB } ( GLuint id ) ;
GL-FUNCTION: GLvoid* glMapBuffer { glMapBufferARB } ( GLenum target, GLenum access ) ;
GL-FUNCTION: GLboolean glUnmapBuffer { glUnmapBufferARB } ( GLenum target ) ;
! OpenGL 2.0
@ -1583,99 +1576,99 @@ GL-FUNCTION: GLboolean glUnmapBuffer ( GLenum target ) ;
TYPEDEF: char GLchar
GL-FUNCTION: void glAttachShader ( GLuint program, GLuint shader ) ;
GL-FUNCTION: void glBindAttribLocation ( GLuint program, GLuint index, GLchar* name ) ;
GL-FUNCTION: void glBlendEquationSeparate ( GLenum modeRGB, GLenum modeAlpha ) ;
GL-FUNCTION: void glCompileShader ( GLuint shader ) ;
GL-FUNCTION: GLuint glCreateProgram ( ) ;
GL-FUNCTION: GLuint glCreateShader ( GLenum type ) ;
GL-FUNCTION: void glDeleteProgram ( GLuint program ) ;
GL-FUNCTION: void glDeleteShader ( GLuint shader ) ;
GL-FUNCTION: void glDetachShader ( GLuint program, GLuint shader ) ;
GL-FUNCTION: void glDisableVertexAttribArray ( GLuint index ) ;
GL-FUNCTION: void glDrawBuffers ( GLsizei n, GLenum* bufs ) ;
GL-FUNCTION: void glEnableVertexAttribArray ( GLuint index ) ;
GL-FUNCTION: void glGetActiveAttrib ( GLuint program, GLuint index, GLsizei maxLength, GLsizei* length, GLint* size, GLenum* type, GLchar* name ) ;
GL-FUNCTION: void glGetActiveUniform ( GLuint program, GLuint index, GLsizei maxLength, GLsizei* length, GLint* size, GLenum* type, GLchar* name ) ;
GL-FUNCTION: void glGetAttachedShaders ( GLuint program, GLsizei maxCount, GLsizei* count, GLuint* shaders ) ;
GL-FUNCTION: GLint glGetAttribLocation ( GLuint program, GLchar* name ) ;
GL-FUNCTION: void glGetProgramInfoLog ( GLuint program, GLsizei bufSize, GLsizei* length, GLchar* infoLog ) ;
GL-FUNCTION: void glGetProgramiv ( GLuint program, GLenum pname, GLint* param ) ;
GL-FUNCTION: void glGetShaderInfoLog ( GLuint shader, GLsizei bufSize, GLsizei* length, GLchar* infoLog ) ;
GL-FUNCTION: void glGetShaderSource ( GLint obj, GLsizei maxLength, GLsizei* length, GLchar* source ) ;
GL-FUNCTION: void glGetShaderiv ( GLuint shader, GLenum pname, GLint* param ) ;
GL-FUNCTION: GLint glGetUniformLocation ( GLint programObj, GLchar* name ) ;
GL-FUNCTION: void glGetUniformfv ( GLuint program, GLint location, GLfloat* params ) ;
GL-FUNCTION: void glGetUniformiv ( GLuint program, GLint location, GLint* params ) ;
GL-FUNCTION: void glGetVertexAttribPointerv ( GLuint index, GLenum pname, GLvoid** pointer ) ;
GL-FUNCTION: void glGetVertexAttribdv ( GLuint index, GLenum pname, GLdouble* params ) ;
GL-FUNCTION: void glGetVertexAttribfv ( GLuint index, GLenum pname, GLfloat* params ) ;
GL-FUNCTION: void glGetVertexAttribiv ( GLuint index, GLenum pname, GLint* params ) ;
GL-FUNCTION: GLboolean glIsProgram ( GLuint program ) ;
GL-FUNCTION: GLboolean glIsShader ( GLuint shader ) ;
GL-FUNCTION: void glLinkProgram ( GLuint program ) ;
GL-FUNCTION: void glShaderSource ( GLuint shader, GLsizei count, GLchar** strings, GLint* lengths ) ;
GL-FUNCTION: void glStencilFuncSeparate ( GLenum frontfunc, GLenum backfunc, GLint ref, GLuint mask ) ;
GL-FUNCTION: void glStencilMaskSeparate ( GLenum face, GLuint mask ) ;
GL-FUNCTION: void glStencilOpSeparate ( GLenum face, GLenum sfail, GLenum dpfail, GLenum dppass ) ;
GL-FUNCTION: void glUniform1f ( GLint location, GLfloat v0 ) ;
GL-FUNCTION: void glUniform1fv ( GLint location, GLsizei count, GLfloat* value ) ;
GL-FUNCTION: void glUniform1i ( GLint location, GLint v0 ) ;
GL-FUNCTION: void glUniform1iv ( GLint location, GLsizei count, GLint* value ) ;
GL-FUNCTION: void glUniform2f ( GLint location, GLfloat v0, GLfloat v1 ) ;
GL-FUNCTION: void glUniform2fv ( GLint location, GLsizei count, GLfloat* value ) ;
GL-FUNCTION: void glUniform2i ( GLint location, GLint v0, GLint v1 ) ;
GL-FUNCTION: void glUniform2iv ( GLint location, GLsizei count, GLint* value ) ;
GL-FUNCTION: void glUniform3f ( GLint location, GLfloat v0, GLfloat v1, GLfloat v2 ) ;
GL-FUNCTION: void glUniform3fv ( GLint location, GLsizei count, GLfloat* value ) ;
GL-FUNCTION: void glUniform3i ( GLint location, GLint v0, GLint v1, GLint v2 ) ;
GL-FUNCTION: void glUniform3iv ( GLint location, GLsizei count, GLint* value ) ;
GL-FUNCTION: void glUniform4f ( GLint location, GLfloat v0, GLfloat v1, GLfloat v2, GLfloat v3 ) ;
GL-FUNCTION: void glUniform4fv ( GLint location, GLsizei count, GLfloat* value ) ;
GL-FUNCTION: void glUniform4i ( GLint location, GLint v0, GLint v1, GLint v2, GLint v3 ) ;
GL-FUNCTION: void glUniform4iv ( GLint location, GLsizei count, GLint* value ) ;
GL-FUNCTION: void glUniformMatrix2fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix3fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix4fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUseProgram ( GLuint program ) ;
GL-FUNCTION: void glValidateProgram ( GLuint program ) ;
GL-FUNCTION: void glVertexAttrib1d ( GLuint index, GLdouble x ) ;
GL-FUNCTION: void glVertexAttrib1dv ( GLuint index, GLdouble* v ) ;
GL-FUNCTION: void glVertexAttrib1f ( GLuint index, GLfloat x ) ;
GL-FUNCTION: void glVertexAttrib1fv ( GLuint index, GLfloat* v ) ;
GL-FUNCTION: void glVertexAttrib1s ( GLuint index, GLshort x ) ;
GL-FUNCTION: void glVertexAttrib1sv ( GLuint index, GLshort* v ) ;
GL-FUNCTION: void glVertexAttrib2d ( GLuint index, GLdouble x, GLdouble y ) ;
GL-FUNCTION: void glVertexAttrib2dv ( GLuint index, GLdouble* v ) ;
GL-FUNCTION: void glVertexAttrib2f ( GLuint index, GLfloat x, GLfloat y ) ;
GL-FUNCTION: void glVertexAttrib2fv ( GLuint index, GLfloat* v ) ;
GL-FUNCTION: void glVertexAttrib2s ( GLuint index, GLshort x, GLshort y ) ;
GL-FUNCTION: void glVertexAttrib2sv ( GLuint index, GLshort* v ) ;
GL-FUNCTION: void glVertexAttrib3d ( GLuint index, GLdouble x, GLdouble y, GLdouble z ) ;
GL-FUNCTION: void glVertexAttrib3dv ( GLuint index, GLdouble* v ) ;
GL-FUNCTION: void glVertexAttrib3f ( GLuint index, GLfloat x, GLfloat y, GLfloat z ) ;
GL-FUNCTION: void glVertexAttrib3fv ( GLuint index, GLfloat* v ) ;
GL-FUNCTION: void glVertexAttrib3s ( GLuint index, GLshort x, GLshort y, GLshort z ) ;
GL-FUNCTION: void glVertexAttrib3sv ( GLuint index, GLshort* v ) ;
GL-FUNCTION: void glVertexAttrib4Nbv ( GLuint index, GLbyte* v ) ;
GL-FUNCTION: void glVertexAttrib4Niv ( GLuint index, GLint* v ) ;
GL-FUNCTION: void glVertexAttrib4Nsv ( GLuint index, GLshort* v ) ;
GL-FUNCTION: void glVertexAttrib4Nub ( GLuint index, GLubyte x, GLubyte y, GLubyte z, GLubyte w ) ;
GL-FUNCTION: void glVertexAttrib4Nubv ( GLuint index, GLubyte* v ) ;
GL-FUNCTION: void glVertexAttrib4Nuiv ( GLuint index, GLuint* v ) ;
GL-FUNCTION: void glVertexAttrib4Nusv ( GLuint index, GLushort* v ) ;
GL-FUNCTION: void glVertexAttrib4bv ( GLuint index, GLbyte* v ) ;
GL-FUNCTION: void glVertexAttrib4d ( GLuint index, GLdouble x, GLdouble y, GLdouble z, GLdouble w ) ;
GL-FUNCTION: void glVertexAttrib4dv ( GLuint index, GLdouble* v ) ;
GL-FUNCTION: void glVertexAttrib4f ( GLuint index, GLfloat x, GLfloat y, GLfloat z, GLfloat w ) ;
GL-FUNCTION: void glVertexAttrib4fv ( GLuint index, GLfloat* v ) ;
GL-FUNCTION: void glVertexAttrib4iv ( GLuint index, GLint* v ) ;
GL-FUNCTION: void glVertexAttrib4s ( GLuint index, GLshort x, GLshort y, GLshort z, GLshort w ) ;
GL-FUNCTION: void glVertexAttrib4sv ( GLuint index, GLshort* v ) ;
GL-FUNCTION: void glVertexAttrib4ubv ( GLuint index, GLubyte* v ) ;
GL-FUNCTION: void glVertexAttrib4uiv ( GLuint index, GLuint* v ) ;
GL-FUNCTION: void glVertexAttrib4usv ( GLuint index, GLushort* v ) ;
GL-FUNCTION: void glVertexAttribPointer ( GLuint index, GLint size, GLenum type, GLboolean normalized, GLsizei stride, GLvoid* pointer ) ;
GL-FUNCTION: void glAttachShader { glAttachObjectARB } ( GLuint program, GLuint shader ) ;
GL-FUNCTION: void glBindAttribLocation { glBindAttribLocationARB } ( GLuint program, GLuint index, GLchar* name ) ;
GL-FUNCTION: void glBlendEquationSeparate { glBlendEquationSeparateEXT } ( GLenum modeRGB, GLenum modeAlpha ) ;
GL-FUNCTION: void glCompileShader { glCompileShaderARB } ( GLuint shader ) ;
GL-FUNCTION: GLuint glCreateProgram { glCreateProgramObjectARB } ( ) ;
GL-FUNCTION: GLuint glCreateShader { glCreateShaderObjectARB } ( GLenum type ) ;
GL-FUNCTION: void glDeleteProgram { glDeleteObjectARB } ( GLuint program ) ;
GL-FUNCTION: void glDeleteShader { glDeleteObjectARB } ( GLuint shader ) ;
GL-FUNCTION: void glDetachShader { glDetachObjectARB } ( GLuint program, GLuint shader ) ;
GL-FUNCTION: void glDisableVertexAttribArray { glDisableVertexAttribArrayARB } ( GLuint index ) ;
GL-FUNCTION: void glDrawBuffers { glDrawBuffersARB glDrawBuffersATI } ( GLsizei n, GLenum* bufs ) ;
GL-FUNCTION: void glEnableVertexAttribArray { glEnableVertexAttribArrayARB } ( GLuint index ) ;
GL-FUNCTION: void glGetActiveAttrib { glGetActiveAttribARB } ( GLuint program, GLuint index, GLsizei maxLength, GLsizei* length, GLint* size, GLenum* type, GLchar* name ) ;
GL-FUNCTION: void glGetActiveUniform { glGetActiveUniformARB } ( GLuint program, GLuint index, GLsizei maxLength, GLsizei* length, GLint* size, GLenum* type, GLchar* name ) ;
GL-FUNCTION: void glGetAttachedShaders { glGetAttachedObjectsARB } ( GLuint program, GLsizei maxCount, GLsizei* count, GLuint* shaders ) ;
GL-FUNCTION: GLint glGetAttribLocation { glGetAttribLocationARB } ( GLuint program, GLchar* name ) ;
GL-FUNCTION: void glGetProgramInfoLog { glGetInfoLogARB } ( GLuint program, GLsizei bufSize, GLsizei* length, GLchar* infoLog ) ;
GL-FUNCTION: void glGetProgramiv { glGetObjectParameterivARB } ( GLuint program, GLenum pname, GLint* param ) ;
GL-FUNCTION: void glGetShaderInfoLog { glGetInfoLogARB } ( GLuint shader, GLsizei bufSize, GLsizei* length, GLchar* infoLog ) ;
GL-FUNCTION: void glGetShaderSource { glGetShaderSourceARB } ( GLint obj, GLsizei maxLength, GLsizei* length, GLchar* source ) ;
GL-FUNCTION: void glGetShaderiv { glGetObjectParameterivARB } ( GLuint shader, GLenum pname, GLint* param ) ;
GL-FUNCTION: GLint glGetUniformLocation { glGetUniformLocationARB } ( GLint programObj, GLchar* name ) ;
GL-FUNCTION: void glGetUniformfv { glGetUniformfvARB } ( GLuint program, GLint location, GLfloat* params ) ;
GL-FUNCTION: void glGetUniformiv { glGetUniformivARB } ( GLuint program, GLint location, GLint* params ) ;
GL-FUNCTION: void glGetVertexAttribPointerv { glGetVertexAttribPointervARB } ( GLuint index, GLenum pname, GLvoid** pointer ) ;
GL-FUNCTION: void glGetVertexAttribdv { glGetVertexAttribdvARB } ( GLuint index, GLenum pname, GLdouble* params ) ;
GL-FUNCTION: void glGetVertexAttribfv { glGetVertexAttribfvARB } ( GLuint index, GLenum pname, GLfloat* params ) ;
GL-FUNCTION: void glGetVertexAttribiv { glGetVertexAttribivARB } ( GLuint index, GLenum pname, GLint* params ) ;
GL-FUNCTION: GLboolean glIsProgram { glIsProgramARB } ( GLuint program ) ;
GL-FUNCTION: GLboolean glIsShader { glIsShaderARB } ( GLuint shader ) ;
GL-FUNCTION: void glLinkProgram { glLinkProgramARB } ( GLuint program ) ;
GL-FUNCTION: void glShaderSource { glShaderSourceARB } ( GLuint shader, GLsizei count, GLchar** strings, GLint* lengths ) ;
GL-FUNCTION: void glStencilFuncSeparate { glStencilFuncSeparateATI } ( GLenum frontfunc, GLenum backfunc, GLint ref, GLuint mask ) ;
GL-FUNCTION: void glStencilMaskSeparate { } ( GLenum face, GLuint mask ) ;
GL-FUNCTION: void glStencilOpSeparate { glStencilOpSeparateATI } ( GLenum face, GLenum sfail, GLenum dpfail, GLenum dppass ) ;
GL-FUNCTION: void glUniform1f { glUniform1fARB } ( GLint location, GLfloat v0 ) ;
GL-FUNCTION: void glUniform1fv { glUniform1fvARB } ( GLint location, GLsizei count, GLfloat* value ) ;
GL-FUNCTION: void glUniform1i { glUniform1iARB } ( GLint location, GLint v0 ) ;
GL-FUNCTION: void glUniform1iv { glUniform1ivARB } ( GLint location, GLsizei count, GLint* value ) ;
GL-FUNCTION: void glUniform2f { glUniform2fARB } ( GLint location, GLfloat v0, GLfloat v1 ) ;
GL-FUNCTION: void glUniform2fv { glUniform2fvARB } ( GLint location, GLsizei count, GLfloat* value ) ;
GL-FUNCTION: void glUniform2i { glUniform2iARB } ( GLint location, GLint v0, GLint v1 ) ;
GL-FUNCTION: void glUniform2iv { glUniform2ivARB } ( GLint location, GLsizei count, GLint* value ) ;
GL-FUNCTION: void glUniform3f { glUniform3fARB } ( GLint location, GLfloat v0, GLfloat v1, GLfloat v2 ) ;
GL-FUNCTION: void glUniform3fv { glUniform3fvARB } ( GLint location, GLsizei count, GLfloat* value ) ;
GL-FUNCTION: void glUniform3i { glUniform3iARB } ( GLint location, GLint v0, GLint v1, GLint v2 ) ;
GL-FUNCTION: void glUniform3iv { glUniform3ivARB } ( GLint location, GLsizei count, GLint* value ) ;
GL-FUNCTION: void glUniform4f { glUniform4fARB } ( GLint location, GLfloat v0, GLfloat v1, GLfloat v2, GLfloat v3 ) ;
GL-FUNCTION: void glUniform4fv { glUniform4fvARB } ( GLint location, GLsizei count, GLfloat* value ) ;
GL-FUNCTION: void glUniform4i { glUniform4iARB } ( GLint location, GLint v0, GLint v1, GLint v2, GLint v3 ) ;
GL-FUNCTION: void glUniform4iv { glUniform4ivARB } ( GLint location, GLsizei count, GLint* value ) ;
GL-FUNCTION: void glUniformMatrix2fv { glUniformMatrix2fvARB } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix3fv { glUniformMatrix3fvARB } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix4fv { glUniformMatrix4fvARB } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUseProgram { glUseProgramObjectARB } ( GLuint program ) ;
GL-FUNCTION: void glValidateProgram { glValidateProgramARB } ( GLuint program ) ;
GL-FUNCTION: void glVertexAttrib1d { glVertexAttrib1dARB } ( GLuint index, GLdouble x ) ;
GL-FUNCTION: void glVertexAttrib1dv { glVertexAttrib1dvARB } ( GLuint index, GLdouble* v ) ;
GL-FUNCTION: void glVertexAttrib1f { glVertexAttrib1fARB } ( GLuint index, GLfloat x ) ;
GL-FUNCTION: void glVertexAttrib1fv { glVertexAttrib1fvARB } ( GLuint index, GLfloat* v ) ;
GL-FUNCTION: void glVertexAttrib1s { glVertexAttrib1sARB } ( GLuint index, GLshort x ) ;
GL-FUNCTION: void glVertexAttrib1sv { glVertexAttrib1svARB } ( GLuint index, GLshort* v ) ;
GL-FUNCTION: void glVertexAttrib2d { glVertexAttrib2dARB } ( GLuint index, GLdouble x, GLdouble y ) ;
GL-FUNCTION: void glVertexAttrib2dv { glVertexAttrib2dvARB } ( GLuint index, GLdouble* v ) ;
GL-FUNCTION: void glVertexAttrib2f { glVertexAttrib2fARB } ( GLuint index, GLfloat x, GLfloat y ) ;
GL-FUNCTION: void glVertexAttrib2fv { glVertexAttrib2fvARB } ( GLuint index, GLfloat* v ) ;
GL-FUNCTION: void glVertexAttrib2s { glVertexAttrib2sARB } ( GLuint index, GLshort x, GLshort y ) ;
GL-FUNCTION: void glVertexAttrib2sv { glVertexAttrib2svARB } ( GLuint index, GLshort* v ) ;
GL-FUNCTION: void glVertexAttrib3d { glVertexAttrib3dARB } ( GLuint index, GLdouble x, GLdouble y, GLdouble z ) ;
GL-FUNCTION: void glVertexAttrib3dv { glVertexAttrib3dvARB } ( GLuint index, GLdouble* v ) ;
GL-FUNCTION: void glVertexAttrib3f { glVertexAttrib3fARB } ( GLuint index, GLfloat x, GLfloat y, GLfloat z ) ;
GL-FUNCTION: void glVertexAttrib3fv { glVertexAttrib3fvARB } ( GLuint index, GLfloat* v ) ;
GL-FUNCTION: void glVertexAttrib3s { glVertexAttrib3sARB } ( GLuint index, GLshort x, GLshort y, GLshort z ) ;
GL-FUNCTION: void glVertexAttrib3sv { glVertexAttrib3svARB } ( GLuint index, GLshort* v ) ;
GL-FUNCTION: void glVertexAttrib4Nbv { glVertexAttrib4NbvARB } ( GLuint index, GLbyte* v ) ;
GL-FUNCTION: void glVertexAttrib4Niv { glVertexAttrib4NivARB } ( GLuint index, GLint* v ) ;
GL-FUNCTION: void glVertexAttrib4Nsv { glVertexAttrib4NsvARB } ( GLuint index, GLshort* v ) ;
GL-FUNCTION: void glVertexAttrib4Nub { glVertexAttrib4NubARB } ( GLuint index, GLubyte x, GLubyte y, GLubyte z, GLubyte w ) ;
GL-FUNCTION: void glVertexAttrib4Nubv { glVertexAttrib4NubvARB } ( GLuint index, GLubyte* v ) ;
GL-FUNCTION: void glVertexAttrib4Nuiv { glVertexAttrib4NuivARB } ( GLuint index, GLuint* v ) ;
GL-FUNCTION: void glVertexAttrib4Nusv { glVertexAttrib4NusvARB } ( GLuint index, GLushort* v ) ;
GL-FUNCTION: void glVertexAttrib4bv { glVertexAttrib4bvARB } ( GLuint index, GLbyte* v ) ;
GL-FUNCTION: void glVertexAttrib4d { glVertexAttrib4dARB } ( GLuint index, GLdouble x, GLdouble y, GLdouble z, GLdouble w ) ;
GL-FUNCTION: void glVertexAttrib4dv { glVertexAttrib4dvARB } ( GLuint index, GLdouble* v ) ;
GL-FUNCTION: void glVertexAttrib4f { glVertexAttrib4fARB } ( GLuint index, GLfloat x, GLfloat y, GLfloat z, GLfloat w ) ;
GL-FUNCTION: void glVertexAttrib4fv { glVertexAttrib4fvARB } ( GLuint index, GLfloat* v ) ;
GL-FUNCTION: void glVertexAttrib4iv { glVertexAttrib4ivARB } ( GLuint index, GLint* v ) ;
GL-FUNCTION: void glVertexAttrib4s { glVertexAttrib4sARB } ( GLuint index, GLshort x, GLshort y, GLshort z, GLshort w ) ;
GL-FUNCTION: void glVertexAttrib4sv { glVertexAttrib4svARB } ( GLuint index, GLshort* v ) ;
GL-FUNCTION: void glVertexAttrib4ubv { glVertexAttrib4ubvARB } ( GLuint index, GLubyte* v ) ;
GL-FUNCTION: void glVertexAttrib4uiv { glVertexAttrib4uivARB } ( GLuint index, GLuint* v ) ;
GL-FUNCTION: void glVertexAttrib4usv { glVertexAttrib4usvARB } ( GLuint index, GLushort* v ) ;
GL-FUNCTION: void glVertexAttribPointer { glVertexAttribPointerARB } ( GLuint index, GLint size, GLenum type, GLboolean normalized, GLsizei stride, GLvoid* pointer ) ;
! OpenGL 2.1
@ -1699,12 +1692,12 @@ GL-FUNCTION: void glVertexAttribPointer ( GLuint index, GLint size, GLenum type,
: GL_COMPRESSED_SLUMINANCE HEX: 8C4A ; inline
: GL_COMPRESSED_SLUMINANCE_ALPHA HEX: 8C4B ; inline
GL-FUNCTION: void glUniformMatrix2x3fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix2x4fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix3x2fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix3x4fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix4x2fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix4x3fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix2x3fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix2x4fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix3x2fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix3x4fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix4x2fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix4x3fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
! GL_EXT_framebuffer_object
@ -1762,23 +1755,23 @@ GL-FUNCTION: void glUniformMatrix4x3fv ( GLint location, GLsizei count, GLboolea
: GL_RENDERBUFFER_DEPTH_SIZE_EXT HEX: 8D54 ; inline
: GL_RENDERBUFFER_STENCIL_SIZE_EXT HEX: 8D55 ; inline
GL-FUNCTION: void glBindFramebufferEXT ( GLenum target, GLuint framebuffer ) ;
GL-FUNCTION: void glBindRenderbufferEXT ( GLenum target, GLuint renderbuffer ) ;
GL-FUNCTION: GLenum glCheckFramebufferStatusEXT ( GLenum target ) ;
GL-FUNCTION: void glDeleteFramebuffersEXT ( GLsizei n, GLuint* framebuffers ) ;
GL-FUNCTION: void glDeleteRenderbuffersEXT ( GLsizei n, GLuint* renderbuffers ) ;
GL-FUNCTION: void glFramebufferRenderbufferEXT ( GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer ) ;
GL-FUNCTION: void glFramebufferTexture1DEXT ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ;
GL-FUNCTION: void glFramebufferTexture2DEXT ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ;
GL-FUNCTION: void glFramebufferTexture3DEXT ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level, GLint zoffset ) ;
GL-FUNCTION: void glGenFramebuffersEXT ( GLsizei n, GLuint* framebuffers ) ;
GL-FUNCTION: void glGenRenderbuffersEXT ( GLsizei n, GLuint* renderbuffers ) ;
GL-FUNCTION: void glGenerateMipmapEXT ( GLenum target ) ;
GL-FUNCTION: void glGetFramebufferAttachmentParameterivEXT ( GLenum target, GLenum attachment, GLenum pname, GLint* params ) ;
GL-FUNCTION: void glGetRenderbufferParameterivEXT ( GLenum target, GLenum pname, GLint* params ) ;
GL-FUNCTION: GLboolean glIsFramebufferEXT ( GLuint framebuffer ) ;
GL-FUNCTION: GLboolean glIsRenderbufferEXT ( GLuint renderbuffer ) ;
GL-FUNCTION: void glRenderbufferStorageEXT ( GLenum target, GLenum internalformat, GLsizei width, GLsizei height ) ;
GL-FUNCTION: void glBindFramebufferEXT { } ( GLenum target, GLuint framebuffer ) ;
GL-FUNCTION: void glBindRenderbufferEXT { } ( GLenum target, GLuint renderbuffer ) ;
GL-FUNCTION: GLenum glCheckFramebufferStatusEXT { } ( GLenum target ) ;
GL-FUNCTION: void glDeleteFramebuffersEXT { } ( GLsizei n, GLuint* framebuffers ) ;
GL-FUNCTION: void glDeleteRenderbuffersEXT { } ( GLsizei n, GLuint* renderbuffers ) ;
GL-FUNCTION: void glFramebufferRenderbufferEXT { } ( GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer ) ;
GL-FUNCTION: void glFramebufferTexture1DEXT { } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ;
GL-FUNCTION: void glFramebufferTexture2DEXT { } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ;
GL-FUNCTION: void glFramebufferTexture3DEXT { } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level, GLint zoffset ) ;
GL-FUNCTION: void glGenFramebuffersEXT { } ( GLsizei n, GLuint* framebuffers ) ;
GL-FUNCTION: void glGenRenderbuffersEXT { } ( GLsizei n, GLuint* renderbuffers ) ;
GL-FUNCTION: void glGenerateMipmapEXT { } ( GLenum target ) ;
GL-FUNCTION: void glGetFramebufferAttachmentParameterivEXT { } ( GLenum target, GLenum attachment, GLenum pname, GLint* params ) ;
GL-FUNCTION: void glGetRenderbufferParameterivEXT { } ( GLenum target, GLenum pname, GLint* params ) ;
GL-FUNCTION: GLboolean glIsFramebufferEXT { } ( GLuint framebuffer ) ;
GL-FUNCTION: GLboolean glIsRenderbufferEXT { } ( GLuint renderbuffer ) ;
GL-FUNCTION: void glRenderbufferStorageEXT { } ( GLenum target, GLenum internalformat, GLsizei width, GLsizei height ) ;
! GL_ARB_texture_float

View File

@ -0,0 +1,6 @@
USING: kernel alien ;
IN: opengl.gl.macosx
: gl-function-context ( -- context ) 0 ; inline
: gl-function-address ( name -- address ) "gl" load-library dlsym ; inline
: gl-function-calling-convention ( -- str ) "cdecl" ; inline

View File

@ -1,5 +1,6 @@
USING: alien.syntax kernel syntax words ;
USING: kernel x11.glx ;
IN: opengl.gl.unix
: GL-FUNCTION: POSTPONE: FUNCTION: ; parsing
: gl-function-context ( -- context ) glXGetCurrentContext ; inline
: gl-function-address ( name -- address ) glXGetProcAddressARB ; inline
: gl-function-calling-convention ( -- str ) "cdecl" ; inline

View File

@ -1,34 +1,6 @@
USING: alien alien.syntax arrays assocs hashtables init kernel
libc math namespaces parser sequences syntax system vectors
windows.opengl32 ;
USING: kernel windows.opengl32 ;
IN: opengl.gl.windows
<PRIVATE
SYMBOL: gl-function-number-counter
SYMBOL: gl-function-pointers
0 gl-function-number-counter set
[ 100 <hashtable> gl-function-pointers set ] "opengl.gl.windows init hook" add-init-hook
: gl-function-number ( -- n )
gl-function-number-counter get
dup 1+ gl-function-number-counter set ;
: gl-function-pointer ( name n -- funptr )
wglGetCurrentContext 2array dup gl-function-pointers get at
[ -rot 2drop ]
[ >r wglGetProcAddress dup r> gl-function-pointers get set-at ]
if* ;
PRIVATE>
: GL-FUNCTION:
"stdcall"
scan
scan
dup gl-function-number [ gl-function-pointer ] 2curry swap
";" parse-tokens [ "()" subseq? not ] subset
define-indirect
; parsing
: gl-function-context ( -- context ) wglGetCurrentContext ; inline
: gl-function-address ( name -- address ) wglGetProcAddress ; inline
: gl-function-calling-convention ( -- str ) "stdcall" ; inline

View File

@ -1,9 +1,10 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes inference inference.dataflow io kernel
kernel.private math.parser namespaces optimizer prettyprint
prettyprint.backend sequences words arrays match macros
assocs sequences.private ;
assocs sequences.private optimizer.specializers generic
combinators sorting math ;
IN: optimizer.debugger
! A simple tool for turning dataflow IR into quotations, for
@ -113,7 +114,62 @@ M: object node>quot dup class word-name comment, ;
: dataflow>quot ( node ? -- quot )
[ swap (dataflow>quot) ] [ ] make ;
: print-dataflow ( quot ? -- )
: optimized-quot. ( quot ? -- )
#! Print dataflow IR for a quotation. Flag indicates if
#! annotations should be printed or not.
>r dataflow optimize r> dataflow>quot pprint nl ;
: optimized-word. ( word ? -- ) >r specialized-def r> optimized-quot. ;
SYMBOL: words-called
SYMBOL: generics-called
SYMBOL: methods-called
SYMBOL: intrinsics-called
SYMBOL: node-count
: dataflow>report ( node -- alist )
[
H{ } clone words-called set
H{ } clone generics-called set
H{ } clone methods-called set
H{ } clone intrinsics-called set
0 swap [
>r 1+ r>
dup #call? [
node-param {
{ [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
{ [ dup generic? ] [ generics-called ] }
{ [ dup method-body? ] [ methods-called ] }
{ [ t ] [ words-called ] }
} cond 1 -rot get at+
] [
drop
] if
] each-node
node-count set
] H{ } make-assoc ;
: quot-optimize-report ( quot -- report )
dataflow optimize dataflow>report ;
: word-optimize-report ( word -- report )
word-def quot-optimize-report ;
: report. ( report -- )
[
"==== Total number of dataflow nodes:" print
node-count get .
{
{ generics-called "==== Generic word calls:" }
{ words-called "==== Ordinary word calls:" }
{ methods-called "==== Non-inlined method calls:" }
{ intrinsics-called "==== Open-coded intrinsic calls:" }
} [
nl print get keys natural-sort stack.
] assoc-each
] bind ;
: optimizer-report. ( word -- )
word-optimize-report report. ;

View File

@ -1,7 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables kernel math math.parser math.ranges project-euler.common
sequences sorting ;
USING: hashtables kernel math math.ranges project-euler.common sequences
sorting ;
IN: project-euler.004
! http://projecteuler.net/index.php?section=problems&id=4
@ -18,9 +18,6 @@ IN: project-euler.004
! SOLUTION
! --------
: palindrome? ( n -- ? )
number>string dup reverse = ;
<PRIVATE
: source-004 ( -- seq )

View File

@ -1,7 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math.ranges math.text.english sequences strings
ascii ;
USING: kernel math.ranges math.text.english sequences sequences.lib strings
ascii ;
IN: project-euler.017
! http://projecteuler.net/index.php?section=problems&id=17

View File

@ -1,7 +1,7 @@
! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar combinators combinators.lib kernel math math.ranges namespaces
sequences ;
USING: calendar combinators kernel math math.ranges namespaces sequences
sequences.lib ;
IN: project-euler.019
! http://projecteuler.net/index.php?section=problems&id=19
@ -32,7 +32,7 @@ IN: project-euler.019
: euler019 ( -- answer )
1901 2000 [a,b] [
12 [1,b] [ 1 zeller-congruence ] 1 map-withn
12 [1,b] [ 1 zeller-congruence ] map-with
] map concat [ zero? ] count ;
! [ euler019 ] 100 ave-time

View File

@ -1,7 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.functions math.ranges namespaces
project-euler.common sequences ;
project-euler.common sequences sequences.lib ;
IN: project-euler.021
! http://projecteuler.net/index.php?section=problems&id=21

View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.ranges ;
USING: kernel math math.ranges sequences.lib ;
IN: project-euler.028
! http://projecteuler.net/index.php?section=problems&id=28

View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.functions project-euler.common sequences ;
USING: kernel math math.functions project-euler.common sequences sequences.lib ;
IN: project-euler.030
! http://projecteuler.net/index.php?section=problems&id=30

View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math.ranges project-euler.common sequences ;
USING: kernel math.ranges project-euler.common sequences sequences.lib ;
IN: project-euler.034
! http://projecteuler.net/index.php?section=problems&id=34

View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.combinatorics math.parser math.primes
project-euler.common sequences ;
USING: kernel math math.combinatorics math.parser math.primes
project-euler.common sequences sequences.lib ;
IN: project-euler.035
! http://projecteuler.net/index.php?section=problems&id=35

View File

@ -1,6 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math.parser math.ranges sequences ;
USING: combinators.lib kernel math.parser math.ranges project-euler.common
sequences ;
IN: project-euler.036
! http://projecteuler.net/index.php?section=problems&id=36
@ -24,12 +25,9 @@ IN: project-euler.036
<PRIVATE
: palindrome? ( str -- ? )
dup reverse = ;
: both-bases? ( n -- ? )
{ [ dup number>string palindrome? ]
[ dup >bin palindrome? ] } && nip ;
{ [ dup palindrome? ]
[ dup >bin dup reverse = ] } && nip ;
PRIVATE>

View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators.lib kernel math math.ranges namespaces
project-euler.common sequences ;
USING: arrays combinators.cleave combinators.lib kernel math math.ranges
namespaces project-euler.common sequences ;
IN: project-euler.039
! http://projecteuler.net/index.php?section=problems&id=39
@ -43,7 +43,7 @@ SYMBOL: p-count
: (count-perimeters) ( seq -- )
dup sum max-p < [
dup sum adjust-p-count
[ u-transform ] keep [ a-transform ] keep d-transform
[ u-transform ] [ a-transform ] [ d-transform ] tri
[ (count-perimeters) ] 3apply
] [
drop

View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: ascii combinators.lib io.files kernel math math.functions namespaces
project-euler.common sequences splitting ;
USING: ascii io.files kernel math math.functions namespaces
project-euler.common sequences sequences.lib splitting ;
IN: project-euler.042
! http://projecteuler.net/index.php?section=problems&id=42

View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib hashtables kernel math math.combinatorics math.parser
math.ranges project-euler.common sequences sorting ;
math.ranges project-euler.common sequences sequences.lib sorting ;
IN: project-euler.043
! http://projecteuler.net/index.php?section=problems&id=43

View File

@ -30,9 +30,6 @@ IN: project-euler.044
: nth-pentagonal ( n -- seq )
dup 3 * 1- * 2 / ;
: pentagonal? ( n -- ? )
dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ;
: sum-and-diff? ( m n -- ? )
2dup + -rot - [ pentagonal? ] 2apply and ;

View File

@ -0,0 +1,49 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math project-euler.common ;
IN: project-euler.045
! http://projecteuler.net/index.php?section=problems&id=45
! DESCRIPTION
! -----------
! Triangle, pentagonal, and hexagonal numbers are generated by the following
! formulae:
! Triangle Tn = n(n + 1) / 2 1, 3, 6, 10, 15, ...
! Pentagonal Pn = n(3n 1) / 2 1, 5, 12, 22, 35, ...
! Hexagonal Hn = n(2n 1) 1, 6, 15, 28, 45, ...
! It can be verified that T285 = P165 = H143 = 40755.
! Find the next triangle number that is also pentagonal and hexagonal.
! SOLUTION
! --------
! All hexagonal numbers are also triangle numbers, so iterate through hexagonal
! numbers until you find one that is pentagonal as well.
<PRIVATE
: nth-hexagonal ( n -- m )
dup 2 * 1- * ;
DEFER: next-solution
: (next-solution) ( n hexagonal -- hexagonal )
dup pentagonal? [ nip ] [ drop next-solution ] if ;
: next-solution ( n -- m )
1+ dup nth-hexagonal (next-solution) ;
PRIVATE>
: euler045 ( -- answer )
143 next-solution ;
! [ euler045 ] 100 ave-time
! 18 ms run / 1 ms GC ave time - 100 trials
MAIN: euler045

View File

@ -0,0 +1,52 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.primes math.ranges sequences ;
IN: project-euler.046
! http://projecteuler.net/index.php?section=problems&id=46
! DESCRIPTION
! -----------
! It was proposed by Christian Goldbach that every odd composite number can be
! written as the sum of a prime and twice a square.
! 9 = 7 + 2 * 1^2
! 15 = 7 + 2 * 2^2
! 21 = 3 + 2 * 3^2
! 25 = 7 + 2 * 3^2
! 27 = 19 + 2 * 2^2
! 33 = 31 + 2 * 1^2
! It turns out that the conjecture was false.
! What is the smallest odd composite that cannot be written as the sum of a
! prime and twice a square?
! SOLUTION
! --------
<PRIVATE
: perfect-squares ( n -- seq )
2 /i sqrt >integer [1,b] [ sq ] map ;
: fits-conjecture? ( n -- ? )
dup perfect-squares [ 2 * - ] with map [ prime? ] contains? ;
: next-odd-composite ( n -- m )
dup odd? [ 2 + ] [ 1+ ] if dup prime? [ next-odd-composite ] when ;
: disprove-conjecture ( n -- m )
dup fits-conjecture? [ next-odd-composite disprove-conjecture ] when ;
PRIVATE>
: euler046 ( -- answer )
9 disprove-conjecture ;
! [ euler046 ] 100 ave-time
! 150 ms run / 2 ms GC ave time - 100 trials
MAIN: euler046

View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.functions ;
USING: kernel math math.functions sequences.lib ;
IN: project-euler.048
! http://projecteuler.net/index.php?section=problems&id=48

View File

@ -0,0 +1,35 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.combinatorics math.ranges sequences.lib ;
IN: project-euler.053
! http://projecteuler.net/index.php?section=problems&id=53
! DESCRIPTION
! -----------
! There are exactly ten ways of selecting three from five, 12345:
! 123, 124, 125, 134, 135, 145, 234, 235, 245, and 345
! In combinatorics, we use the notation, 5C3 = 10.
! In general,
! nCr = n! / r! * (n - r)!
! where r ≤ n, n! = n * (n 1) * ... * 3 * 2 * 1, and 0! = 1.
! It is not until n = 23, that a value exceeds one-million: 23C10 = 1144066.
! How many values of nCr, for 1 ≤ n ≤ 100, are greater than one-million?
! SOLUTION
! --------
: euler053 ( -- answer )
23 100 [a,b] [ dup [ nCk 1000000 > ] with count ] sigma ;
! [ euler053 ] 100 ave-time
! 64 ms run / 2 ms GC ave time - 100 trials
MAIN: euler053

View File

@ -0,0 +1,69 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.parser project-euler.common sequences sequences.lib ;
IN: project-euler.055
! http://projecteuler.net/index.php?section=problems&id=55
! DESCRIPTION
! -----------
! If we take 47, reverse and add, 47 + 74 = 121, which is palindromic.
! Not all numbers produce palindromes so quickly. For example,
! 349 + 943 = 1292,
! 1292 + 2921 = 4213
! 4213 + 3124 = 7337
! That is, 349 took three iterations to arrive at a palindrome.
! Although no one has proved it yet, it is thought that some numbers, like 196,
! never produce a palindrome. A number that never forms a palindrome through
! the reverse and add process is called a Lychrel number. Due to the
! theoretical nature of these numbers, and for the purpose of this problem, we
! shall assume that a number is Lychrel until proven otherwise. In addition you
! are given that for every number below ten-thousand, it will either (i) become a
! palindrome in less than fifty iterations, or, (ii) no one, with all the
! computing power that exists, has managed so far to map it to a palindrome. In
! fact, 10677 is the first number to be shown to require over fifty iterations
! before producing a palindrome: 4668731596684224866951378664 (53 iterations,
! 28-digits).
! Surprisingly, there are palindromic numbers that are themselves Lychrel
! numbers; the first example is 4994.
! How many Lychrel numbers are there below ten-thousand?
! NOTE: Wording was modified slightly on 24 April 2007 to emphasise the
! theoretical nature of Lychrel numbers.
! SOLUTION
! --------
<PRIVATE
: add-reverse ( n -- m )
dup number>digits reverse 10 digits>integer + ;
: (lychrel?) ( n iteration -- ? )
dup 50 < [
>r add-reverse dup palindrome?
[ r> 2drop f ] [ r> 1+ (lychrel?) ] if
] [
2drop t
] if ;
: lychrel? ( n -- ? )
1 (lychrel?) ;
PRIVATE>
: euler055 ( -- answer )
10000 [ lychrel? ] count ;
! [ euler055 ] 100 ave-time
! 1370 ms run / 31 ms GC ave time - 100 trials
MAIN: euler055

View File

@ -0,0 +1,31 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.functions math.ranges project-euler.common sequences ;
IN: project-euler.056
! http://projecteuler.net/index.php?section=problems&id=56
! DESCRIPTION
! -----------
! A googol (10^100) is a massive number: one followed by one-hundred zeros;
! 100^100 is almost unimaginably large: one followed by two-hundred zeros.
! Despite their size, the sum of the digits in each number is only 1.
! Considering natural numbers of the form, a^b, where a, b < 100, what is the
! maximum digital sum?
! SOLUTION
! --------
! Through analysis, you only need to check when a and b > 90
: euler056 ( -- answer )
90 100 [a,b) dup cartesian-product
[ first2 ^ number>digits sum ] map supremum ;
! [ euler056 ] 100 ave-time
! 33 ms run / 1 ms GC ave time - 100 trials
MAIN: euler056

View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators.lib kernel math math.ranges namespaces
project-euler.common sequences ;
USING: arrays combinators.cleave combinators.lib kernel math math.ranges
namespaces project-euler.common sequences sequences.lib ;
IN: project-euler.075
! http://projecteuler.net/index.php?section=problems&id=75
@ -56,7 +56,7 @@ SYMBOL: p-count
: (count-perimeters) ( seq -- )
dup sum max-p < [
dup sum adjust-p-count
[ u-transform ] keep [ a-transform ] keep d-transform
[ u-transform ] [ a-transform ] [ d-transform ] tri
[ (count-perimeters) ] 3apply
] [
drop

View File

@ -0,0 +1,54 @@
! Copyright (c) 2008 Aaron Schaefer, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.ranges sequences ;
IN: project-euler.092
! http://projecteuler.net/index.php?section=problems&id=92
! DESCRIPTION
! -----------
! A number chain is created by continuously adding the square of the digits in
! a number to form a new number until it has been seen before.
! For example,
! 44 -> 32 -> 13 -> 10 -> 1 -> 1
! 85 -> 89 -> 145 -> 42 -> 20 -> 4 -> 16 -> 37 -> 58 -> 89
! Therefore any chain that arrives at 1 or 89 will become stuck in an endless
! loop. What is most amazing is that EVERY starting number will eventually
! arrive at 1 or 89.
! How many starting numbers below ten million will arrive at 89?
! SOLUTION
! --------
<PRIVATE
: next-link ( n -- m )
0 swap [ dup zero? not ] [ 10 /mod sq -rot [ + ] dip ] [ ] while drop ;
: chain-ending ( n -- m )
dup 1 = over 89 = or [ next-link chain-ending ] unless ;
: lower-endings ( -- seq )
567 [1,b] [ chain-ending ] map ;
: fast-chain-ending ( seq n -- m )
dup 567 > [ next-link ] when 1- swap nth ;
: count ( seq quot -- n )
0 -rot [ rot >r call [ r> 1+ ] [ r> ] if ] curry each ; inline
PRIVATE>
: euler092 ( -- answer )
lower-endings 9999999 [1,b] [ fast-chain-ending 89 = ] with count ;
! [ euler092 ] 10 ave-time
! 11169 ms run / 0 ms GC ave time - 10 trials
MAIN: euler092

View File

@ -1,6 +1,6 @@
USING: arrays combinators.lib kernel math math.functions math.miller-rabin
math.matrices math.parser math.primes.factors math.ranges namespaces
sequences sorting unicode.case ;
USING: arrays kernel math math.functions math.miller-rabin math.matrices
math.parser math.primes.factors math.ranges namespaces sequences
sequences.lib sorting unicode.case ;
IN: project-euler.common
! A collection of words used by more than one Project Euler solution
@ -9,13 +9,15 @@ IN: project-euler.common
! Problems using each public word
! -------------------------------
! alpha-value - #22, #42
! cartesian-product - #4, #27, #29, #32, #33
! cartesian-product - #4, #27, #29, #32, #33, #43, #44, #56
! collect-consecutive - #8, #11
! log10 - #25, #134
! max-path - #18, #67
! nth-triangle - #12, #42
! number>digits - #16, #20, #30, #34
! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56
! palindrome? - #4, #36, #55
! pandigital? - #32, #38
! pentagonal? - #44, #45
! propagate-all - #18, #67
! sum-proper-divisors - #21
! tau* - #12
@ -76,14 +78,20 @@ PRIVATE>
] if ;
: number>digits ( n -- seq )
number>string string>digits ;
[ dup zero? not ] [ 10 /mod ] [ ] unfold reverse nip ;
: nth-triangle ( n -- n )
dup 1+ * 2 / ;
: palindrome? ( n -- ? )
number>string dup reverse = ;
: pandigital? ( n -- ? )
number>string natural-sort "123456789" = ;
: pentagonal? ( n -- ? )
dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ;
! Not strictly needed, but it is nice to be able to dump the triangle after the
! propagation
: propagate-all ( triangle -- newtriangle )

View File

@ -13,9 +13,10 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time
project-euler.033 project-euler.034 project-euler.035 project-euler.036
project-euler.037 project-euler.038 project-euler.039 project-euler.040
project-euler.041 project-euler.042 project-euler.043 project-euler.044
project-euler.048 project-euler.052 project-euler.067 project-euler.075
project-euler.079 project-euler.097 project-euler.134 project-euler.169
project-euler.173 project-euler.175 ;
project-euler.045 project-euler.046 project-euler.048 project-euler.052
project-euler.053 project-euler.056 project-euler.067 project-euler.075
project-euler.079 project-euler.092 project-euler.097 project-euler.134
project-euler.169 project-euler.173 project-euler.175 ;
IN: project-euler
<PRIVATE

View File

@ -1,5 +1,18 @@
USING: arrays kernel sequences sequences.lib math
math.functions tools.test strings math.ranges ;
USING: arrays kernel sequences sequences.lib math math.functions math.ranges
tools.test strings ;
IN: temporary
[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test
[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test
[ 328350 ] [ 100 [ sq ] sigma ] unit-test
[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
[ 4 ] [ { 1 2 } [ sq ] [ * ] map-reduce ] unit-test
[ 36 ] [ { 2 3 } [ sq ] [ * ] map-reduce ] unit-test
@ -7,6 +20,8 @@ math.functions tools.test strings math.ranges ;
[ 10 ] [ { 1 2 3 4 } [ + ] reduce* ] unit-test
[ 24 ] [ { 1 2 3 4 } [ * ] reduce* ] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test
[ -4 ] [ 1 -4 [ abs ] higher ] unit-test
[ 1 ] [ 1 -4 [ abs ] lower ] unit-test

View File

@ -3,7 +3,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel sequences math namespaces assocs
random sequences.private shuffle math.functions mirrors
arrays math.parser sorting strings ascii macros ;
arrays math.parser math.private sorting strings ascii macros ;
IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline
@ -190,7 +190,18 @@ PRIVATE>
! List the positions of obj in seq
: indices ( seq obj -- seq )
>r dup length swap r>
[ = [ ] [ drop f ] if ] curry
2map
[ ] subset ;
>r dup length swap r>
[ = [ ] [ drop f ] if ] curry
2map
[ ] subset ;
<PRIVATE
: (attempt-each-integer) ( i n quot -- result )
[
iterate-step roll
[ 3nip ] [ iterate-next (attempt-each-integer) ] if*
] [ 3drop f ] if-iterate? ; inline
PRIVATE>
: attempt-each ( seq quot -- result )
(each) iterate-prep (attempt-each-integer) ; inline

View File

@ -25,6 +25,8 @@ MACRO: ntuck ( n -- ) 2 + [ dup , -nrot ] bake ;
: 3nip ( a b c d -- d ) 3 nnip ; inline
: 4nip ( a b c d e -- e ) 4 nnip ; inline
: 4dup ( a b c d -- a b c d a b c d ) 4 ndup ; inline
: 4drop ( a b c d -- ) 3drop drop ; inline

View File

@ -41,7 +41,6 @@ TUPLE: fica-base-unknown ;
MIXIN: collector
GENERIC: adjust-allowances ( salary w4 collector -- newsalary )
GENERIC: withholding ( salary w4 collector -- x )
GENERIC: net ( salary w4 collector -- x )
TUPLE: tax-table single married ;
@ -102,14 +101,6 @@ M: federal withholding ( salary w4 tax-table -- x )
[ fica-tax ] 2keep
medicare-tax + + ;
M: federal net ( salary w4 collector -- x )
>r dupd r> withholding - ;
M: collector net ( salary w4 collector -- x )
>r dupd r>
[ withholding ] 3keep
drop <federal> withholding + - ;
! Minnesota
: minnesota-single ( -- triples )
@ -138,3 +129,10 @@ M: minnesota adjust-allowances ( salary w4 collector -- newsalary )
M: minnesota withholding ( salary w4 collector -- x )
[ adjust-allowances ] 2keep marriage-table tax ;
: employer-withhold ( salary w4 collector -- x )
[ withholding ] 3keep
dup federal? [ 3drop ] [ drop <federal> withholding + ] if ;
: net ( salary w4 collector -- x )
>r dupd r> employer-withhold - ;

Some files were not shown because too many files have changed in this diff Show More