Merge branch 'master' of http://factorcode.org/git/factor into experimental
Conflicts: extra/semantic-db/semantic-db.factordb4
Alex Chapman
commit
ab796422e5
|
|
@ -270,7 +270,7 @@ M: no-such-symbol compiler-error-type
|
|||
pop-literal nip >>library
|
||||
pop-literal nip >>return
|
||||
! Quotation which coerces parameters to required types
|
||||
dup param-prep-quot f infer-quot
|
||||
dup param-prep-quot recursive-state get infer-quot
|
||||
! Set ABI
|
||||
dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
|
||||
! Add node to IR
|
||||
|
|
@ -278,7 +278,7 @@ M: no-such-symbol compiler-error-type
|
|||
! Magic #: consume exactly the number of inputs
|
||||
dup 0 alien-invoke-stack
|
||||
! Quotation which coerces return value to required type
|
||||
return-prep-quot f infer-quot
|
||||
return-prep-quot recursive-state get infer-quot
|
||||
] "infer" set-word-prop
|
||||
|
||||
M: #alien-invoke generate-node
|
||||
|
|
@ -306,13 +306,13 @@ M: alien-indirect-error summary
|
|||
pop-parameters >>parameters
|
||||
pop-literal nip >>return
|
||||
! Quotation which coerces parameters to required types
|
||||
dup param-prep-quot [ dip ] curry f infer-quot
|
||||
dup param-prep-quot [ dip ] curry recursive-state get infer-quot
|
||||
! Add node to IR
|
||||
dup node,
|
||||
! Magic #: consume the function pointer, too
|
||||
dup 1 alien-invoke-stack
|
||||
! Quotation which coerces return value to required type
|
||||
return-prep-quot f infer-quot
|
||||
return-prep-quot recursive-state get infer-quot
|
||||
] "infer" set-word-prop
|
||||
|
||||
M: #alien-indirect generate-node
|
||||
|
|
@ -345,7 +345,7 @@ M: alien-callback-error summary
|
|||
|
||||
: callback-bottom ( node -- )
|
||||
xt>> [ word-xt drop <alien> ] curry
|
||||
f infer-quot ;
|
||||
recursive-state get infer-quot ;
|
||||
|
||||
\ alien-callback [
|
||||
4 ensure-values
|
||||
|
|
|
|||
|
|
@ -18,6 +18,8 @@ IN: bootstrap.compiler
|
|||
|
||||
enable-compiler
|
||||
|
||||
: compile-uncompiled [ compiled? not ] filter compile ;
|
||||
|
||||
nl
|
||||
"Compiling..." write flush
|
||||
|
||||
|
|
@ -42,38 +44,38 @@ nl
|
|||
find-pair-next namestack*
|
||||
|
||||
bitand bitor bitxor bitnot
|
||||
} compile
|
||||
} compile-uncompiled
|
||||
|
||||
"." write flush
|
||||
|
||||
{
|
||||
+ 1+ 1- 2/ < <= > >= shift min
|
||||
} compile
|
||||
+ 1+ 1- 2/ < <= > >= shift
|
||||
} compile-uncompiled
|
||||
|
||||
"." write flush
|
||||
|
||||
{
|
||||
new-sequence nth push pop peek
|
||||
} compile
|
||||
} compile-uncompiled
|
||||
|
||||
"." write flush
|
||||
|
||||
{
|
||||
hashcode* = get set
|
||||
} compile
|
||||
} compile-uncompiled
|
||||
|
||||
"." write flush
|
||||
|
||||
{
|
||||
. lines
|
||||
} compile
|
||||
} compile-uncompiled
|
||||
|
||||
"." write flush
|
||||
|
||||
{
|
||||
malloc calloc free memcpy
|
||||
} compile
|
||||
} compile-uncompiled
|
||||
|
||||
vocabs [ words [ compiled? not ] filter compile "." write flush ] each
|
||||
vocabs [ words compile-uncompiled "." write flush ] each
|
||||
|
||||
" done" print flush
|
||||
|
|
|
|||
|
|
@ -1,5 +1,22 @@
|
|||
IN: bootstrap.image.tests
|
||||
USING: bootstrap.image bootstrap.image.private tools.test ;
|
||||
USING: bootstrap.image bootstrap.image.private tools.test
|
||||
kernel math ;
|
||||
|
||||
\ ' must-infer
|
||||
\ write-image must-infer
|
||||
|
||||
[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
|
||||
|
||||
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test
|
||||
|
||||
[ f ] [ [ 2drop 0 ] [ 2drop 0.0 ] eql? ] unit-test
|
||||
|
||||
[ t ] [ [ 2drop 0 ] [ 2drop 0 ] eql? ] unit-test
|
||||
|
||||
[ f ] [ \ + [ 2drop 0 ] eql? ] unit-test
|
||||
|
||||
[ f ] [ 3 [ 0 1 2 ] eql? ] unit-test
|
||||
|
||||
[ f ] [ 3 3.0 eql? ] unit-test
|
||||
|
||||
[ t ] [ 4.0 4.0 eql? ] unit-test
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ splitting growable classes classes.builtin classes.tuple
|
|||
classes.tuple.private words.private io.binary io.files vocabs
|
||||
vocabs.loader source-files definitions debugger float-arrays
|
||||
quotations.private sequences.private combinators
|
||||
io.encodings.binary math.order ;
|
||||
io.encodings.binary math.order accessors ;
|
||||
IN: bootstrap.image
|
||||
|
||||
: my-arch ( -- arch )
|
||||
|
|
@ -31,6 +31,43 @@ IN: bootstrap.image
|
|||
|
||||
<PRIVATE
|
||||
|
||||
! Object cache; we only consider numbers equal if they have the
|
||||
! same type
|
||||
TUPLE: id obj ;
|
||||
|
||||
C: <id> id
|
||||
|
||||
M: id hashcode* obj>> hashcode* ;
|
||||
|
||||
GENERIC: (eql?) ( obj1 obj2 -- ? )
|
||||
|
||||
: eql? ( obj1 obj2 -- ? )
|
||||
[ (eql?) ] [ [ class ] bi@ = ] 2bi and ;
|
||||
|
||||
M: integer (eql?) = ;
|
||||
|
||||
M: sequence (eql?)
|
||||
over sequence? [
|
||||
2dup [ length ] bi@ =
|
||||
[ [ eql? ] 2all? ] [ 2drop f ] if
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
M: object (eql?) = ;
|
||||
|
||||
M: id equal?
|
||||
over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
|
||||
|
||||
SYMBOL: objects
|
||||
|
||||
: (objects) <id> objects get ; inline
|
||||
|
||||
: lookup-object ( obj -- n/f ) (objects) at ;
|
||||
|
||||
: put-object ( n obj -- ) (objects) set-at ;
|
||||
|
||||
: cache-object ( obj quot -- value )
|
||||
>r (objects) r> [ obj>> ] prepose cache ; inline
|
||||
|
||||
! Constants
|
||||
|
||||
: image-magic HEX: 0f0e0d0c ; inline
|
||||
|
|
@ -61,9 +98,6 @@ IN: bootstrap.image
|
|||
! The image being constructed; a vector of word-size integers
|
||||
SYMBOL: image
|
||||
|
||||
! Object cache
|
||||
SYMBOL: objects
|
||||
|
||||
! Image output format
|
||||
SYMBOL: big-endian
|
||||
|
||||
|
|
@ -187,7 +221,9 @@ GENERIC: ' ( obj -- ptr )
|
|||
2tri ;
|
||||
|
||||
M: bignum '
|
||||
bignum tag-number dup [ emit-bignum ] emit-object ;
|
||||
[
|
||||
bignum tag-number dup [ emit-bignum ] emit-object
|
||||
] cache-object ;
|
||||
|
||||
! Fixnums
|
||||
|
||||
|
|
@ -202,9 +238,11 @@ M: fixnum '
|
|||
! Floats
|
||||
|
||||
M: float '
|
||||
float tag-number dup [
|
||||
align-here double>bits emit-64
|
||||
] emit-object ;
|
||||
[
|
||||
float tag-number dup [
|
||||
align-here double>bits emit-64
|
||||
] emit-object
|
||||
] cache-object ;
|
||||
|
||||
! Special objects
|
||||
|
||||
|
|
@ -243,7 +281,7 @@ M: f '
|
|||
] bi
|
||||
\ word type-number object tag-number
|
||||
[ emit-seq ] emit-object
|
||||
] keep objects get set-at ;
|
||||
] keep put-object ;
|
||||
|
||||
: word-error ( word msg -- * )
|
||||
[ % dup word-vocabulary % " " % word-name % ] "" make throw ;
|
||||
|
|
@ -252,7 +290,7 @@ M: f '
|
|||
[ target-word ] keep or ;
|
||||
|
||||
: fixup-word ( word -- offset )
|
||||
transfer-word dup objects get at
|
||||
transfer-word dup lookup-object
|
||||
[ ] [ "Not in image: " word-error ] ?if ;
|
||||
|
||||
: fixup-words ( -- )
|
||||
|
|
@ -286,7 +324,7 @@ M: wrapper '
|
|||
M: string '
|
||||
#! We pool strings so that each string is only written once
|
||||
#! to the image
|
||||
objects get [ emit-string ] cache ;
|
||||
[ emit-string ] cache-object ;
|
||||
|
||||
: assert-empty ( seq -- )
|
||||
length 0 assert= ;
|
||||
|
|
@ -311,12 +349,12 @@ M: float-array ' float-array emit-dummy-array ;
|
|||
|
||||
: emit-tuple ( tuple -- pointer )
|
||||
dup class word-name "tombstone" =
|
||||
[ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ;
|
||||
[ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
|
||||
|
||||
M: tuple ' emit-tuple ;
|
||||
|
||||
M: tuple-layout '
|
||||
objects get [
|
||||
[
|
||||
[
|
||||
{
|
||||
[ layout-hashcode , ]
|
||||
|
|
@ -328,12 +366,12 @@ M: tuple-layout '
|
|||
] { } make [ ' ] map
|
||||
\ tuple-layout type-number
|
||||
object tag-number [ emit-seq ] emit-object
|
||||
] cache ;
|
||||
] cache-object ;
|
||||
|
||||
M: tombstone '
|
||||
delegate
|
||||
"((tombstone))" "((empty))" ? "hashtables.private" lookup
|
||||
word-def first objects get [ emit-tuple ] cache ;
|
||||
word-def first [ emit-tuple ] cache-object ;
|
||||
|
||||
! Arrays
|
||||
M: array '
|
||||
|
|
@ -343,7 +381,7 @@ M: array '
|
|||
! Quotations
|
||||
|
||||
M: quotation '
|
||||
objects get [
|
||||
[
|
||||
quotation-array '
|
||||
quotation type-number object tag-number [
|
||||
emit ! array
|
||||
|
|
@ -351,7 +389,7 @@ M: quotation '
|
|||
0 emit ! xt
|
||||
0 emit ! code
|
||||
] emit-object
|
||||
] cache ;
|
||||
] cache-object ;
|
||||
|
||||
! End of the image
|
||||
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@ HELP: case
|
|||
"If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied."
|
||||
$nl
|
||||
"The following two phrases are equivalent:"
|
||||
{ $code "{ { X [ Y ] } { Y [ T ] } } case" }
|
||||
{ $code "{ { X [ Y ] } { Z [ T ] } } case" }
|
||||
{ $code "dup X = [ drop Y ] [ dup Z = [ drop T ] [ no-case ] if ] if" }
|
||||
}
|
||||
{ $examples
|
||||
|
|
|
|||
|
|
@ -97,10 +97,10 @@ M: relative-overflow summary
|
|||
|
||||
: assert-depth ( quot -- )
|
||||
>r datastack r> swap slip >r datastack r>
|
||||
2dup [ length ] compare sgn {
|
||||
{ -1 [ trim-datastacks nip relative-underflow ] }
|
||||
{ 0 [ 2drop ] }
|
||||
{ 1 [ trim-datastacks drop relative-overflow ] }
|
||||
2dup [ length ] compare {
|
||||
{ +lt+ [ trim-datastacks nip relative-underflow ] }
|
||||
{ +eq+ [ 2drop ] }
|
||||
{ +gt+ [ trim-datastacks drop relative-overflow ] }
|
||||
} case ; inline
|
||||
|
||||
: expired-error. ( obj -- )
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ PREDICATE: math-class < class
|
|||
} cond ;
|
||||
|
||||
: math-class-max ( class class -- class )
|
||||
[ [ math-precedence ] compare 0 > ] most ;
|
||||
[ [ math-precedence ] compare +gt+ eq? ] most ;
|
||||
|
||||
: (math-upgrade) ( max class -- quot )
|
||||
dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;
|
||||
|
|
|
|||
|
|
@ -92,11 +92,11 @@ M: priority-queue heap-size ( heap -- n )
|
|||
|
||||
GENERIC: heap-compare ( pair1 pair2 heap -- ? )
|
||||
|
||||
: (heap-compare) drop [ entry-key ] compare 0 ; inline
|
||||
: (heap-compare) drop [ entry-key ] compare ; inline
|
||||
|
||||
M: min-heap heap-compare (heap-compare) > ;
|
||||
M: min-heap heap-compare (heap-compare) +gt+ eq? ;
|
||||
|
||||
M: max-heap heap-compare (heap-compare) < ;
|
||||
M: max-heap heap-compare (heap-compare) +lt+ eq? ;
|
||||
|
||||
: heap-bounds-check? ( m heap -- ? )
|
||||
heap-size >= ; inline
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ M: object value-literal \ literal-expected inference-warning ;
|
|||
: value-vector ( n -- vector ) [ drop <computed> ] V{ } map-as ;
|
||||
|
||||
: add-inputs ( seq stack -- n stack )
|
||||
tuck [ length ] compare dup 0 >
|
||||
tuck [ length ] bi@ - dup 0 >
|
||||
[ dup value-vector [ swapd push-all ] keep ]
|
||||
[ drop 0 swap ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: generic help.markup help.syntax math memory
|
||||
namespaces sequences kernel.private layouts sorting classes
|
||||
namespaces sequences kernel.private layouts classes
|
||||
kernel.private vectors combinators quotations strings words
|
||||
assocs arrays math.order ;
|
||||
IN: kernel
|
||||
|
|
@ -241,7 +241,7 @@ ARTICLE: "conditionals" "Conditionals and logic"
|
|||
"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
|
||||
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
|
||||
|
||||
ARTICLE: "equality" "Equality and comparison testing"
|
||||
ARTICLE: "equality" "Equality"
|
||||
"There are two distinct notions of ``sameness'' when it comes to objects. You can test if two references point to the same object (" { $emphasis "identity comparison" } "), or you can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "). Both notions of equality are equality relations in the mathematical sense."
|
||||
$nl
|
||||
"Identity comparison:"
|
||||
|
|
@ -250,15 +250,8 @@ $nl
|
|||
{ $subsection = }
|
||||
"Custom value comparison methods:"
|
||||
{ $subsection equal? }
|
||||
"Utility class:"
|
||||
{ $subsection identity-tuple }
|
||||
"Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":"
|
||||
{ $subsection <=> }
|
||||
{ $subsection compare }
|
||||
"Utilities for comparing objects:"
|
||||
{ $subsection after? }
|
||||
{ $subsection before? }
|
||||
{ $subsection after=? }
|
||||
{ $subsection before=? }
|
||||
"An object can be cloned; the clone has distinct identity but equal value:"
|
||||
{ $subsection clone } ;
|
||||
|
||||
|
|
@ -393,8 +386,6 @@ HELP: identity-tuple
|
|||
{ $unchecked-example "T{ foo } dup clone = ." "f" }
|
||||
} ;
|
||||
|
||||
{ <=> compare natural-sort sort-keys sort-values } related-words
|
||||
|
||||
HELP: clone
|
||||
{ $values { "obj" object } { "cloned" "a new object" } }
|
||||
{ $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;
|
||||
|
|
|
|||
|
|
@ -6,8 +6,6 @@ IN: math.floats.private
|
|||
M: fixnum >float fixnum>float ;
|
||||
M: bignum >float bignum>float ;
|
||||
|
||||
M: float zero? dup 0.0 float= swap -0.0 float= or ;
|
||||
|
||||
M: float >fixnum float>fixnum ;
|
||||
M: float >bignum float>bignum ;
|
||||
M: float >float ;
|
||||
|
|
@ -22,4 +20,7 @@ M: float + float+ ;
|
|||
M: float - float- ;
|
||||
M: float * float* ;
|
||||
M: float / float/f ;
|
||||
M: float /f float/f ;
|
||||
M: float mod float-mod ;
|
||||
|
||||
M: real abs dup 0 < [ neg ] when ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: kernel math namespaces prettyprint
|
||||
math.private continuations tools.test sequences ;
|
||||
USING: kernel math math.functions namespaces prettyprint
|
||||
math.private continuations tools.test sequences random ;
|
||||
IN: math.integers.tests
|
||||
|
||||
[ "-8" ] [ -8 unparse ] unit-test
|
||||
|
|
@ -191,3 +191,31 @@ unit-test
|
|||
[ f ] [ -128 power-of-2? ] unit-test
|
||||
[ f ] [ 0 power-of-2? ] unit-test
|
||||
[ t ] [ 1 power-of-2? ] unit-test
|
||||
|
||||
: ratio>float [ >bignum ] bi@ /f ;
|
||||
|
||||
[ 5. ] [ 5 1 ratio>float ] unit-test
|
||||
[ 4. ] [ 4 1 ratio>float ] unit-test
|
||||
[ 2. ] [ 2 1 ratio>float ] unit-test
|
||||
[ .5 ] [ 1 2 ratio>float ] unit-test
|
||||
[ .75 ] [ 3 4 ratio>float ] unit-test
|
||||
[ 1. ] [ 2000 2^ 2000 2^ 1+ ratio>float ] unit-test
|
||||
[ -1. ] [ 2000 2^ neg 2000 2^ 1+ ratio>float ] unit-test
|
||||
[ 0.4 ] [ 6 15 ratio>float ] unit-test
|
||||
|
||||
[ HEX: 3fe553522d230931 ]
|
||||
[ 61967020039 92984792073 ratio>float double>bits ] unit-test
|
||||
|
||||
: random-integer
|
||||
32 random-bits
|
||||
1 random zero? [ neg ] when
|
||||
1 random zero? [ >bignum ] when ;
|
||||
|
||||
[ t ] [
|
||||
1000 [
|
||||
drop
|
||||
random-integer
|
||||
random-integer
|
||||
[ >float / ] [ /f ] 2bi 0.1 ~
|
||||
] all?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2008, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel kernel.private sequences
|
||||
sequences.private math math.private combinators ;
|
||||
|
|
@ -22,6 +23,8 @@ M: fixnum + fixnum+ ;
|
|||
M: fixnum - fixnum- ;
|
||||
M: fixnum * fixnum* ;
|
||||
M: fixnum /i fixnum/i ;
|
||||
M: fixnum /f >r >float r> >float float/f ;
|
||||
|
||||
M: fixnum mod fixnum-mod ;
|
||||
|
||||
M: fixnum /mod fixnum/mod ;
|
||||
|
|
@ -67,4 +70,57 @@ M: bignum bitnot bignum-bitnot ;
|
|||
M: bignum bit? bignum-bit? ;
|
||||
M: bignum (log2) bignum-log2 ;
|
||||
|
||||
M: integer zero? 0 number= ;
|
||||
! Converting ratios to floats. Based on FLOAT-RATIO from
|
||||
! sbcl/src/code/float.lisp, which has the following license:
|
||||
|
||||
! "The software is in the public domain and is
|
||||
! provided with absolutely no warranty."
|
||||
|
||||
! First step: pre-scaling
|
||||
: twos ( x -- y ) dup 1- bitxor log2 ; inline
|
||||
|
||||
: scale-denonimator ( den -- scaled-den scale' )
|
||||
dup twos neg [ shift ] keep ; inline
|
||||
|
||||
: pre-scale ( num den -- scale shifted-num scaled-den )
|
||||
2dup [ log2 ] bi@ -
|
||||
tuck [ neg 54 + shift ] [ >r scale-denonimator r> + ] 2bi*
|
||||
-rot ; inline
|
||||
|
||||
! Second step: loop
|
||||
: shift-mantissa ( scale mantissa -- scale' mantissa' )
|
||||
[ 1+ ] [ 2/ ] bi* ; inline
|
||||
|
||||
: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
|
||||
[ 2dup /i log2 53 > ]
|
||||
[ >r shift-mantissa r> ]
|
||||
[ ] while /mod ; inline
|
||||
|
||||
! Third step: post-scaling
|
||||
: unscaled-float ( mantissa -- n )
|
||||
52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline
|
||||
|
||||
: scale-float ( scale mantissa -- float' )
|
||||
>r dup 0 < [ neg 2^ recip ] [ 2^ ] if r> * ; inline
|
||||
|
||||
: post-scale ( scale mantissa -- n )
|
||||
2/ dup log2 52 > [ shift-mantissa ] when
|
||||
unscaled-float scale-float ; inline
|
||||
|
||||
! Main word
|
||||
: /f-abs ( m n -- f )
|
||||
over zero? [
|
||||
2drop 0.0
|
||||
] [
|
||||
dup zero? [
|
||||
2drop 1.0/0.0
|
||||
] [
|
||||
pre-scale
|
||||
/f-loop over odd?
|
||||
[ zero? [ 1+ ] unless ] [ drop ] if
|
||||
post-scale
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
M: bignum /f ( m n -- f )
|
||||
[ [ abs ] bi@ /f-abs ] [ [ 0 < ] bi@ xor ] 2bi [ neg ] when ;
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ MATH: + ( x y -- z ) foldable
|
|||
MATH: - ( x y -- z ) foldable
|
||||
MATH: * ( x y -- z ) foldable
|
||||
MATH: / ( x y -- z ) foldable
|
||||
MATH: /f ( x y -- z ) foldable
|
||||
MATH: /i ( x y -- z ) foldable
|
||||
MATH: mod ( x y -- z ) foldable
|
||||
|
||||
|
|
@ -33,6 +34,8 @@ GENERIC# shift 1 ( x n -- y ) foldable
|
|||
GENERIC: bitnot ( x -- y ) foldable
|
||||
GENERIC# bit? 1 ( x n -- ? ) foldable
|
||||
|
||||
GENERIC: abs ( x -- y ) foldable
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: (log2) ( x -- n ) foldable
|
||||
|
|
@ -46,10 +49,7 @@ PRIVATE>
|
|||
(log2)
|
||||
] if ; foldable
|
||||
|
||||
GENERIC: zero? ( x -- ? ) foldable
|
||||
|
||||
M: object zero? drop f ;
|
||||
|
||||
: zero? ( x -- ? ) 0 number= ; inline
|
||||
: 1+ ( x -- y ) 1 + ; inline
|
||||
: 1- ( x -- y ) 1 - ; inline
|
||||
: 2/ ( x -- y ) -1 shift ; inline
|
||||
|
|
@ -60,8 +60,6 @@ M: object zero? drop f ;
|
|||
|
||||
: ?1+ [ 1+ ] [ 0 ] if* ; inline
|
||||
|
||||
: /f ( x y -- z ) >r >float r> >float float/f ; inline
|
||||
|
||||
: rem ( x y -- z ) tuck mod over + swap mod ; foldable
|
||||
|
||||
: 2^ ( n -- 2^n ) 1 swap shift ; inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1,94 @@
|
|||
USING: help.markup help.syntax kernel math quotations
|
||||
math.private words ;
|
||||
IN: math.order
|
||||
|
||||
HELP: <=>
|
||||
{ $values { "obj1" object } { "obj2" object } { "symbol" symbol } }
|
||||
{ $contract
|
||||
"Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings."
|
||||
$nl
|
||||
"The output value is one of the following:"
|
||||
{ $list
|
||||
{ { $link +lt+ } " - indicating that " { $snippet "obj1" } " precedes " { $snippet "obj2" } }
|
||||
{ { $link +eq+ } " - indicating that " { $snippet "obj1" } " is equal to " { $snippet "obj2" } }
|
||||
{ { $link +gt+ } " - indicating that " { $snippet "obj1" } " follows " { $snippet "obj2" } }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: +lt+
|
||||
{ $description "Returned by " { $link <=> } " when the first object is strictly less than the second object." } ;
|
||||
|
||||
HELP: +eq+
|
||||
{ $description "Returned by " { $link <=> } " when the first object is equal to the second object." } ;
|
||||
|
||||
HELP: +gt+
|
||||
{ $description "Returned by " { $link <=> } " when the first object is strictly greater than the second object." } ;
|
||||
|
||||
HELP: invert-comparison
|
||||
{ $values { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" }
|
||||
{ "new-symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } }
|
||||
{ $description "Invert the comparison symbol returned by " { $link <=> } ". The output for the symbol " { $snippet "+eq+" } " is itself." }
|
||||
{ $examples
|
||||
{ $example "USING: math.order prettyprint ;" "+lt+ invert-comparison ." "+gt+" } } ;
|
||||
|
||||
HELP: compare
|
||||
{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } }
|
||||
{ $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." }
|
||||
{ $examples { $example "USING: kernel math.order prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "+gt+" }
|
||||
} ;
|
||||
|
||||
HELP: max
|
||||
{ $values { "x" real } { "y" real } { "z" real } }
|
||||
{ $description "Outputs the greatest of two real numbers." } ;
|
||||
|
||||
HELP: min
|
||||
{ $values { "x" real } { "y" real } { "z" real } }
|
||||
{ $description "Outputs the smallest of two real numbers." } ;
|
||||
|
||||
HELP: between?
|
||||
{ $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } }
|
||||
{ $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." }
|
||||
{ $notes "As per the closed interval notation, the end-points are included in the interval." } ;
|
||||
|
||||
HELP: before?
|
||||
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
|
||||
{ $description "Tests if " { $snippet "obj1" } " comes before " { $snippet "obj2" } " using an intrinsic total order." }
|
||||
{ $notes "Implemented using " { $link <=> } "." } ;
|
||||
|
||||
HELP: after?
|
||||
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
|
||||
{ $description "Tests if " { $snippet "obj1" } " comes after " { $snippet "obj2" } " using an intrinsic total order." }
|
||||
{ $notes "Implemented using " { $link <=> } "." } ;
|
||||
|
||||
HELP: before=?
|
||||
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
|
||||
{ $description "Tests if " { $snippet "obj1" } " comes before or equals " { $snippet "obj2" } " using an intrinsic total order." }
|
||||
{ $notes "Implemented using " { $link <=> } "." } ;
|
||||
|
||||
HELP: after=?
|
||||
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
|
||||
{ $description "Tests if " { $snippet "obj1" } " comes after or equals " { $snippet "obj2" } " using an intrinsic total order." }
|
||||
{ $notes "Implemented using " { $link <=> } "." } ;
|
||||
|
||||
{ before? after? before=? after=? } related-words
|
||||
|
||||
HELP: [-]
|
||||
{ $values { "x" real } { "y" real } { "z" real } }
|
||||
{ $description "Subtracts " { $snippet "y" } " from " { $snippet "x" } ". If the result is less than zero, outputs zero." } ;
|
||||
|
||||
ARTICLE: "math.order" "Ordered objects"
|
||||
"Some classes have an intrinsic order amongst instances:"
|
||||
{ $subsection <=> }
|
||||
{ $subsection compare }
|
||||
{ $subsection invert-comparison }
|
||||
"The above words return one of the following symbols:"
|
||||
{ $subsection +lt+ }
|
||||
{ $subsection +eq+ }
|
||||
{ $subsection +gt+ }
|
||||
"Utilities for comparing objects:"
|
||||
{ $subsection after? }
|
||||
{ $subsection before? }
|
||||
{ $subsection after=? }
|
||||
{ $subsection before=? } ;
|
||||
|
||||
ABOUT: "math.order"
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
USING: kernel math.order tools.test ;
|
||||
IN: math.order.tests
|
||||
|
||||
[ +lt+ ] [ "ab" "abc" <=> ] unit-test
|
||||
[ +gt+ ] [ "abc" "ab" <=> ] unit-test
|
||||
[ +lt+ ] [ 3 4 <=> ] unit-test
|
||||
[ +eq+ ] [ 4 4 <=> ] unit-test
|
||||
[ +gt+ ] [ 4 3 <=> ] unit-test
|
||||
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
! Copyright (C) 2008 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math ;
|
||||
IN: math.order
|
||||
|
||||
SYMBOL: +lt+
|
||||
SYMBOL: +eq+
|
||||
SYMBOL: +gt+
|
||||
|
||||
GENERIC: <=> ( obj1 obj2 -- symbol )
|
||||
|
||||
: (<=>) ( a b -- symbol )
|
||||
2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; inline
|
||||
|
||||
: invert-comparison ( symbol -- new-symbol )
|
||||
#! Can't use case, index or nth here
|
||||
dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ;
|
||||
|
||||
M: real <=> (<=>) ;
|
||||
M: integer <=> (<=>) ;
|
||||
|
||||
GENERIC: before? ( obj1 obj2 -- ? )
|
||||
GENERIC: after? ( obj1 obj2 -- ? )
|
||||
GENERIC: before=? ( obj1 obj2 -- ? )
|
||||
GENERIC: after=? ( obj1 obj2 -- ? )
|
||||
|
||||
M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ;
|
||||
M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ;
|
||||
M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ;
|
||||
M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ;
|
||||
|
||||
M: real before? ( obj1 obj2 -- ? ) < ;
|
||||
M: real after? ( obj1 obj2 -- ? ) > ;
|
||||
M: real before=? ( obj1 obj2 -- ? ) <= ;
|
||||
M: real after=? ( obj1 obj2 -- ? ) >= ;
|
||||
|
||||
: min ( x y -- z ) [ before? ] most ; inline
|
||||
: max ( x y -- z ) [ after? ] most ; inline
|
||||
|
||||
: between? ( x y z -- ? )
|
||||
pick after=? [ after=? ] [ 2drop f ] if ; inline
|
||||
|
||||
: [-] ( x y -- z ) - 0 max ; inline
|
||||
|
||||
: compare ( obj1 obj2 quot -- symbol ) bi@ <=> ; inline
|
||||
|
|
@ -62,3 +62,5 @@ HELP: binsearch*
|
|||
{ $description "Variant of " { $link binsearch } " which outputs the found element rather than its index in the sequence."
|
||||
$nl
|
||||
"Outputs " { $link f } " if the sequence is empty. If the sequence has at least one element, this word always outputs a sequence element." } ;
|
||||
|
||||
{ <=> compare natural-sort sort-keys sort-values } related-words
|
||||
|
|
|
|||
|
|
@ -19,10 +19,10 @@ unit-test
|
|||
|
||||
[ 3 ] [ { 1 2 3 4 } midpoint ] unit-test
|
||||
|
||||
[ f ] [ 3 { } [ - ] binsearch ] unit-test
|
||||
[ 0 ] [ 3 { 3 } [ - ] binsearch ] unit-test
|
||||
[ 1 ] [ 2 { 1 2 3 } [ - ] binsearch ] unit-test
|
||||
[ 3 ] [ 4 { 1 2 3 4 5 6 } [ - ] binsearch ] unit-test
|
||||
[ 1 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ - ] binsearch ] unit-test
|
||||
[ 3 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ - ] binsearch ] unit-test
|
||||
[ 10 ] [ 10 20 >vector [ - ] binsearch ] unit-test
|
||||
[ f ] [ 3 { } [ <=> ] binsearch ] unit-test
|
||||
[ 0 ] [ 3 { 3 } [ <=> ] binsearch ] unit-test
|
||||
[ 1 ] [ 2 { 1 2 3 } [ <=> ] binsearch ] unit-test
|
||||
[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] binsearch ] unit-test
|
||||
[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test
|
||||
[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test
|
||||
[ 10 ] [ 10 20 >vector [ <=> ] binsearch ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math sequences vectors math.order
|
||||
sequences sequences.private growable ;
|
||||
sequences sequences.private growable math.order ;
|
||||
IN: sorting
|
||||
|
||||
DEFER: sort
|
||||
|
|
@ -17,7 +17,7 @@ DEFER: sort
|
|||
dup slice-from 1+ swap set-slice-from ; inline
|
||||
|
||||
: smallest ( iter1 iter2 quot -- elt )
|
||||
>r over this over this r> call 0 <
|
||||
>r over this over this r> call +lt+ eq?
|
||||
-rot ? [ this ] keep next ; inline
|
||||
|
||||
: (merge) ( iter1 iter2 quot accum -- )
|
||||
|
|
@ -58,13 +58,13 @@ PRIVATE>
|
|||
[ midpoint@ ] keep nth-unsafe ; inline
|
||||
|
||||
: partition ( seq n -- slice )
|
||||
1 < swap halves ? ; inline
|
||||
+gt+ eq? not swap halves ? ; inline
|
||||
|
||||
: (binsearch) ( elt quot seq -- i )
|
||||
dup length 1 <= [
|
||||
slice-from 2nip
|
||||
] [
|
||||
[ midpoint swap call ] 3keep roll dup zero?
|
||||
[ midpoint swap call ] 3keep roll dup +eq+ eq?
|
||||
[ drop dup slice-from swap midpoint@ + 2nip ]
|
||||
[ partition (binsearch) ] if
|
||||
] if ; inline
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ IN: builder.release.branch
|
|||
{
|
||||
"scp"
|
||||
my-boot-image-name
|
||||
"factorcode.org:/var/www/factorcode.org/newsite/images/clean"
|
||||
{ "factorcode.org:/var/www/factorcode.org/newsite/images/clean/" platform }
|
||||
}
|
||||
to-strings
|
||||
try-process ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ opengl.glu shuffle http.client vectors namespaces ui.gadgets
|
|||
ui.gadgets.canvas ui.render ui splitting combinators tools.time
|
||||
system combinators.lib float-arrays continuations
|
||||
opengl.demo-support multiline ui.gestures bunny.fixed-pipeline
|
||||
bunny.cel-shaded bunny.outlined bunny.model ;
|
||||
bunny.cel-shaded bunny.outlined bunny.model accessors ;
|
||||
IN: bunny
|
||||
|
||||
TUPLE: bunny-gadget model geom draw-seq draw-n ;
|
||||
|
|
@ -13,38 +13,33 @@ TUPLE: bunny-gadget model geom draw-seq draw-n ;
|
|||
0.0 0.0 0.375 <demo-gadget>
|
||||
maybe-download read-model {
|
||||
set-delegate
|
||||
set-bunny-gadget-model
|
||||
(>>model)
|
||||
} bunny-gadget construct ;
|
||||
|
||||
: bunny-gadget-draw ( gadget -- draw )
|
||||
{ bunny-gadget-draw-n bunny-gadget-draw-seq }
|
||||
{ draw-n>> draw-seq>> }
|
||||
get-slots nth ;
|
||||
|
||||
: bunny-gadget-next-draw ( gadget -- )
|
||||
dup { bunny-gadget-draw-seq bunny-gadget-draw-n }
|
||||
dup { draw-seq>> draw-n>> }
|
||||
get-slots
|
||||
1+ swap length mod
|
||||
swap [ set-bunny-gadget-draw-n ] keep relayout-1 ;
|
||||
>>draw-n relayout-1 ;
|
||||
|
||||
M: bunny-gadget graft* ( gadget -- )
|
||||
GL_DEPTH_TEST glEnable
|
||||
dup bunny-gadget-model <bunny-geom>
|
||||
over {
|
||||
[ <bunny-fixed-pipeline> ]
|
||||
[ <bunny-cel-shaded> ]
|
||||
[ <bunny-outlined> ]
|
||||
} map-call-with [ ] filter
|
||||
0
|
||||
roll {
|
||||
set-bunny-gadget-geom
|
||||
set-bunny-gadget-draw-seq
|
||||
set-bunny-gadget-draw-n
|
||||
} set-slots ;
|
||||
dup model>> <bunny-geom> >>geom
|
||||
dup
|
||||
[ <bunny-fixed-pipeline> ]
|
||||
[ <bunny-cel-shaded> ]
|
||||
[ <bunny-outlined> ] tri 3array
|
||||
[ ] filter >>draw-seq
|
||||
0 >>draw-n
|
||||
drop ;
|
||||
|
||||
M: bunny-gadget ungraft* ( gadget -- )
|
||||
{ bunny-gadget-geom bunny-gadget-draw-seq } get-slots
|
||||
[ [ dispose ] when* ] each
|
||||
[ dispose ] when* ;
|
||||
[ geom>> [ dispose ] when* ]
|
||||
[ draw-seq>> [ [ dispose ] when* ] each ] bi ;
|
||||
|
||||
M: bunny-gadget draw-gadget* ( gadget -- )
|
||||
0.15 0.15 0.15 1.0 glClearColor
|
||||
|
|
@ -52,7 +47,7 @@ M: bunny-gadget draw-gadget* ( gadget -- )
|
|||
dup demo-gadget-set-matrices
|
||||
GL_MODELVIEW glMatrixMode
|
||||
0.02 -0.105 0.0 glTranslatef
|
||||
{ bunny-gadget-geom bunny-gadget-draw } get-slots
|
||||
{ geom>> bunny-gadget-draw } get-slots
|
||||
draw-bunny ;
|
||||
|
||||
M: bunny-gadget pref-dim* ( gadget -- dim )
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: arrays bunny.model continuations kernel multiline opengl opengl.shaders
|
||||
opengl.capabilities opengl.gl sequences sequences.lib ;
|
||||
opengl.capabilities opengl.gl sequences sequences.lib accessors ;
|
||||
IN: bunny.cel-shaded
|
||||
|
||||
STRING: vertex-shader-source
|
||||
|
|
@ -68,11 +68,12 @@ TUPLE: bunny-cel-shaded program ;
|
|||
: <bunny-cel-shaded> ( gadget -- draw )
|
||||
drop
|
||||
cel-shading-supported? [
|
||||
bunny-cel-shaded new
|
||||
vertex-shader-source <vertex-shader> check-gl-shader
|
||||
cel-shaded-fragment-shader-lib-source <fragment-shader> check-gl-shader
|
||||
cel-shaded-fragment-shader-main-source <fragment-shader> check-gl-shader
|
||||
3array <gl-program> check-gl-program
|
||||
{ set-bunny-cel-shaded-program } bunny-cel-shaded construct
|
||||
>>program
|
||||
] [ f ] if ;
|
||||
|
||||
: (draw-cel-shaded-bunny) ( geom program -- )
|
||||
|
|
@ -85,8 +86,8 @@ TUPLE: bunny-cel-shaded program ;
|
|||
} [ bunny-geom ] with-gl-program ;
|
||||
|
||||
M: bunny-cel-shaded draw-bunny
|
||||
bunny-cel-shaded-program (draw-cel-shaded-bunny) ;
|
||||
program>> (draw-cel-shaded-bunny) ;
|
||||
|
||||
M: bunny-cel-shaded dispose
|
||||
bunny-cel-shaded-program delete-gl-program ;
|
||||
program>> delete-gl-program ;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ TUPLE: bunny-fixed-pipeline ;
|
|||
|
||||
: <bunny-fixed-pipeline> ( gadget -- draw )
|
||||
drop
|
||||
{ } bunny-fixed-pipeline construct ;
|
||||
bunny-fixed-pipeline new ;
|
||||
|
||||
M: bunny-fixed-pipeline draw-bunny
|
||||
drop
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: alien alien.c-types arrays sequences math math.vectors
|
|||
math.matrices math.parser io io.files kernel opengl opengl.gl
|
||||
opengl.glu io.encodings.ascii opengl.capabilities shuffle
|
||||
http.client vectors splitting tools.time system combinators
|
||||
float-arrays continuations namespaces sequences.lib ;
|
||||
float-arrays continuations namespaces sequences.lib accessors ;
|
||||
IN: bunny.model
|
||||
|
||||
: numbers ( str -- seq )
|
||||
|
|
@ -85,24 +85,24 @@ M: bunny-dlist bunny-geom
|
|||
bunny-dlist-list glCallList ;
|
||||
|
||||
M: bunny-buffers bunny-geom
|
||||
dup {
|
||||
bunny-buffers-array
|
||||
bunny-buffers-element-array
|
||||
} get-slots [
|
||||
dup { array>> element-array>> } get-slots [
|
||||
{ GL_VERTEX_ARRAY GL_NORMAL_ARRAY } [
|
||||
GL_DOUBLE 0 0 buffer-offset glNormalPointer
|
||||
dup bunny-buffers-nv "double" heap-size * buffer-offset
|
||||
3 GL_DOUBLE 0 roll glVertexPointer
|
||||
bunny-buffers-ni
|
||||
GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
|
||||
[
|
||||
nv>> "double" heap-size * buffer-offset
|
||||
3 GL_DOUBLE 0 roll glVertexPointer
|
||||
] [
|
||||
ni>>
|
||||
GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
|
||||
] bi
|
||||
] all-enabled-client-state
|
||||
] with-array-element-buffers ;
|
||||
|
||||
M: bunny-dlist dispose
|
||||
bunny-dlist-list delete-dlist ;
|
||||
list>> delete-dlist ;
|
||||
|
||||
M: bunny-buffers dispose
|
||||
{ bunny-buffers-array bunny-buffers-element-array } get-slots
|
||||
{ array>> element-array>> } get-slots
|
||||
delete-gl-buffer delete-gl-buffer ;
|
||||
|
||||
: <bunny-geom> ( model -- geom )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
USING: arrays bunny.model bunny.cel-shaded continuations kernel
|
||||
math multiline opengl opengl.shaders opengl.framebuffers
|
||||
opengl.gl opengl.capabilities sequences ui.gadgets combinators ;
|
||||
opengl.gl opengl.capabilities sequences ui.gadgets combinators
|
||||
accessors ;
|
||||
IN: bunny.outlined
|
||||
|
||||
STRING: outlined-pass1-fragment-shader-main-source
|
||||
|
|
@ -139,9 +140,9 @@ TUPLE: bunny-outlined
|
|||
: <bunny-outlined> ( gadget -- draw )
|
||||
outlining-supported? [
|
||||
pass1-program pass2-program {
|
||||
set-bunny-outlined-gadget
|
||||
set-bunny-outlined-pass1-program
|
||||
set-bunny-outlined-pass2-program
|
||||
(>>gadget)
|
||||
(>>pass1-program)
|
||||
(>>pass2-program)
|
||||
} bunny-outlined construct
|
||||
] [ drop f ] if ;
|
||||
|
||||
|
|
@ -169,35 +170,33 @@ TUPLE: bunny-outlined
|
|||
] with-framebuffer ;
|
||||
|
||||
: dispose-framebuffer ( draw -- )
|
||||
dup bunny-outlined-framebuffer-dim [
|
||||
dup framebuffer-dim>> [
|
||||
{
|
||||
[ bunny-outlined-framebuffer [ delete-framebuffer ] when* ]
|
||||
[ bunny-outlined-color-texture [ delete-texture ] when* ]
|
||||
[ bunny-outlined-normal-texture [ delete-texture ] when* ]
|
||||
[ bunny-outlined-depth-texture [ delete-texture ] when* ]
|
||||
[ f swap set-bunny-outlined-framebuffer-dim ]
|
||||
[ framebuffer>> [ delete-framebuffer ] when* ]
|
||||
[ color-texture>> [ delete-texture ] when* ]
|
||||
[ normal-texture>> [ delete-texture ] when* ]
|
||||
[ depth-texture>> [ delete-texture ] when* ]
|
||||
[ f >>framebuffer-dim drop ]
|
||||
} cleave
|
||||
] [ drop ] if ;
|
||||
|
||||
: remake-framebuffer-if-needed ( draw -- )
|
||||
dup bunny-outlined-gadget rect-dim
|
||||
over bunny-outlined-framebuffer-dim
|
||||
dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi
|
||||
over =
|
||||
[ 2drop ]
|
||||
[
|
||||
swap dup dispose-framebuffer >r
|
||||
dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
|
||||
swap dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
|
||||
swap dup GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture)
|
||||
swap >r
|
||||
[ (make-framebuffer) ] 3keep
|
||||
r> r> {
|
||||
set-bunny-outlined-framebuffer
|
||||
set-bunny-outlined-color-texture
|
||||
set-bunny-outlined-normal-texture
|
||||
set-bunny-outlined-depth-texture
|
||||
set-bunny-outlined-framebuffer-dim
|
||||
} set-slots
|
||||
[ 2drop ] [
|
||||
[ dup dispose-framebuffer dup ] dip {
|
||||
[
|
||||
GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
|
||||
[ >>color-texture drop ] keep
|
||||
] [
|
||||
GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
|
||||
[ >>normal-texture drop ] keep
|
||||
] [
|
||||
GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture)
|
||||
[ >>depth-texture drop ] keep
|
||||
]
|
||||
} 2cleave
|
||||
(make-framebuffer) >>framebuffer drop
|
||||
] if ;
|
||||
|
||||
: clear-framebuffer ( -- )
|
||||
|
|
@ -209,31 +208,34 @@ TUPLE: bunny-outlined
|
|||
GL_COLOR_BUFFER_BIT glClear ;
|
||||
|
||||
: (pass1) ( geom draw -- )
|
||||
dup bunny-outlined-framebuffer [
|
||||
dup framebuffer>> [
|
||||
clear-framebuffer
|
||||
{ GL_COLOR_ATTACHMENT0_EXT GL_COLOR_ATTACHMENT1_EXT } set-draw-buffers
|
||||
bunny-outlined-pass1-program (draw-cel-shaded-bunny)
|
||||
pass1-program>> (draw-cel-shaded-bunny)
|
||||
] with-framebuffer ;
|
||||
|
||||
: (pass2) ( draw -- )
|
||||
init-matrices
|
||||
dup bunny-outlined-color-texture GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
|
||||
dup bunny-outlined-normal-texture GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit
|
||||
dup bunny-outlined-depth-texture GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit
|
||||
bunny-outlined-pass2-program {
|
||||
{ "colormap" [ 0 glUniform1i ] }
|
||||
{ "normalmap" [ 1 glUniform1i ] }
|
||||
{ "depthmap" [ 2 glUniform1i ] }
|
||||
{ "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] }
|
||||
} [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] with-gl-program ;
|
||||
init-matrices {
|
||||
[ color-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
|
||||
[ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ]
|
||||
[ depth-texture>> GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ]
|
||||
[
|
||||
pass2-program>> {
|
||||
{ "colormap" [ 0 glUniform1i ] }
|
||||
{ "normalmap" [ 1 glUniform1i ] }
|
||||
{ "depthmap" [ 2 glUniform1i ] }
|
||||
{ "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] }
|
||||
} [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ]
|
||||
with-gl-program
|
||||
]
|
||||
} cleave ;
|
||||
|
||||
M: bunny-outlined draw-bunny
|
||||
dup remake-framebuffer-if-needed
|
||||
[ (pass1) ] keep (pass2) ;
|
||||
[ remake-framebuffer-if-needed ]
|
||||
[ (pass1) ]
|
||||
[ (pass2) ] tri ;
|
||||
|
||||
M: bunny-outlined dispose
|
||||
{
|
||||
[ bunny-outlined-pass1-program [ delete-gl-program ] when* ]
|
||||
[ bunny-outlined-pass2-program [ delete-gl-program ] when* ]
|
||||
[ dispose-framebuffer ]
|
||||
} cleave ;
|
||||
[ pass1-program>> [ delete-gl-program ] when* ]
|
||||
[ pass2-program>> [ delete-gl-program ] when* ]
|
||||
[ dispose-framebuffer ] tri ;
|
||||
|
|
|
|||
|
|
@ -131,16 +131,16 @@ IN: calendar.tests
|
|||
[ t ] [ 2004 1 1 23 0 0 9+1/2 hours <timestamp> >gmt
|
||||
2004 1 1 13 30 0 instant <timestamp> = ] unit-test
|
||||
|
||||
[ 0 ] [ 2004 1 1 13 30 0 instant <timestamp>
|
||||
[ +eq+ ] [ 2004 1 1 13 30 0 instant <timestamp>
|
||||
2004 1 1 12 30 0 -1 hours <timestamp> <=> ] unit-test
|
||||
|
||||
[ 1 ] [ 2004 1 1 13 30 0 instant <timestamp>
|
||||
[ +gt+ ] [ 2004 1 1 13 30 0 instant <timestamp>
|
||||
2004 1 1 12 30 0 instant <timestamp> <=> ] unit-test
|
||||
|
||||
[ -1 ] [ 2004 1 1 12 30 0 instant <timestamp>
|
||||
[ +lt+ ] [ 2004 1 1 12 30 0 instant <timestamp>
|
||||
2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
|
||||
|
||||
[ 1 ] [ 2005 1 1 12 30 0 instant <timestamp>
|
||||
[ +gt+ ] [ 2005 1 1 12 30 0 instant <timestamp>
|
||||
2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
|
||||
|
||||
[ t ] [ now timestamp>millis millis - 1000 < ] unit-test
|
||||
|
|
|
|||
|
|
@ -87,10 +87,10 @@ M: timestamp year. ( timestamp -- )
|
|||
[ hh ] [ mm ] bi ;
|
||||
|
||||
: write-gmt-offset ( gmt-offset -- )
|
||||
dup instant <=> sgn {
|
||||
{ 0 [ drop "GMT" write ] }
|
||||
{ -1 [ "-" write before (write-gmt-offset) ] }
|
||||
{ 1 [ "+" write (write-gmt-offset) ] }
|
||||
dup instant <=> {
|
||||
{ +eq+ [ drop "GMT" write ] }
|
||||
{ +lt+ [ "-" write before (write-gmt-offset) ] }
|
||||
{ +gt+ [ "+" write (write-gmt-offset) ] }
|
||||
} case ;
|
||||
|
||||
: timestamp>rfc822 ( timestamp -- str )
|
||||
|
|
@ -118,10 +118,10 @@ M: timestamp year. ( timestamp -- )
|
|||
[ hh ":" write ] [ mm ] bi ;
|
||||
|
||||
: write-rfc3339-gmt-offset ( duration -- )
|
||||
dup instant <=> sgn {
|
||||
{ 0 [ drop "Z" write ] }
|
||||
{ -1 [ "-" write before (write-rfc3339-gmt-offset) ] }
|
||||
{ 1 [ "+" write (write-rfc3339-gmt-offset) ] }
|
||||
dup instant <=> {
|
||||
{ +eq+ [ drop "Z" write ] }
|
||||
{ +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }
|
||||
{ +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }
|
||||
} case ;
|
||||
|
||||
: (timestamp>rfc3339) ( timestamp -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Phil Dawes
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
USING: help.syntax help.markup kernel prettyprint sequences ;
|
||||
IN: csv
|
||||
|
||||
HELP: csv
|
||||
{ $values { "stream" "a stream" }
|
||||
{ "rows" "an array of arrays of fields" } }
|
||||
{ $description "parses a csv stream into an array of row arrays"
|
||||
} ;
|
||||
|
||||
HELP: csv-row
|
||||
{ $values { "stream" "a stream" }
|
||||
{ "row" "an array of fields" } }
|
||||
{ $description "parses a row from a csv stream"
|
||||
} ;
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
USING: io.streams.string csv tools.test shuffle ;
|
||||
IN: csv.tests
|
||||
|
||||
! I like to name my unit tests
|
||||
: named-unit-test ( name output input -- )
|
||||
nipd unit-test ; inline
|
||||
|
||||
! tests nicked from the wikipedia csv article
|
||||
! http://en.wikipedia.org/wiki/Comma-separated_values
|
||||
|
||||
"Fields are separated by commas"
|
||||
[ { { "1997" "Ford" "E350" } } ]
|
||||
[ "1997,Ford,E350" <string-reader> csv ] named-unit-test
|
||||
|
||||
"ignores whitespace before and after elements. n.b.specifically prohibited by RFC 4180, which states, 'Spaces are considered part of a field and should not be ignored.'"
|
||||
[ { { "1997" "Ford" "E350" } } ]
|
||||
[ "1997, Ford , E350" <string-reader> csv ] named-unit-test
|
||||
|
||||
"keeps spaces in quotes"
|
||||
[ { { "1997" "Ford" "E350" "Super, luxurious truck" } } ]
|
||||
[ "1997,Ford,E350,\"Super, luxurious truck\"" <string-reader> csv ] named-unit-test
|
||||
|
||||
"double quotes mean escaped in quotes"
|
||||
[ { { "1997" "Ford" "E350" "Super \"luxurious\" truck" } } ]
|
||||
[ "1997,Ford,E350,\"Super \"\"luxurious\"\" truck\""
|
||||
<string-reader> csv ] named-unit-test
|
||||
|
||||
"Fields with embedded line breaks must be delimited by double-quote characters."
|
||||
[ { { "1997" "Ford" "E350" "Go get one now\nthey are going fast" } } ]
|
||||
[ "1997,Ford,E350,\"Go get one now\nthey are going fast\""
|
||||
<string-reader> csv ] named-unit-test
|
||||
|
||||
"Fields with leading or trailing spaces must be delimited by double-quote characters. (See comment about leading and trailing spaces above)"
|
||||
[ { { "1997" "Ford" "E350" " Super luxurious truck " } } ]
|
||||
[ "1997,Ford,E350,\" Super luxurious truck \""
|
||||
<string-reader> csv ] named-unit-test
|
||||
|
||||
"Fields may always be delimited by double-quote characters, whether necessary or not."
|
||||
[ { { "1997" "Ford" "E350" } } ]
|
||||
[ "\"1997\",\"Ford\",\"E350\"" <string-reader> csv ] named-unit-test
|
||||
|
||||
"The first record in a csv file may contain column names in each of the fields."
|
||||
[ { { "Year" "Make" "Model" }
|
||||
{ "1997" "Ford" "E350" }
|
||||
{ "2000" "Mercury" "Cougar" } } ]
|
||||
[ "Year,Make,Model\n1997,Ford,E350\n2000,Mercury,Cougar"
|
||||
<string-reader> csv ] named-unit-test
|
||||
|
||||
|
||||
|
||||
! !!!!!!!! other tests
|
||||
|
||||
[ { { "Phil Dawes" } } ]
|
||||
[ "\"Phil Dawes\"" <string-reader> csv ] unit-test
|
||||
|
||||
[ { { "1" "2" "3" } { "4" "5" "6" } } ]
|
||||
[ "1,2,3\n4,5,6\n" <string-reader> csv ] unit-test
|
||||
|
||||
"trims leading and trailing whitespace - n.b. this isn't really conformant, but lots of csv seems to assume this"
|
||||
[ { { "foo yeah" "bah" "baz" } } ]
|
||||
[ " foo yeah , bah ,baz\n" <string-reader> csv ] named-unit-test
|
||||
|
|
@ -0,0 +1,60 @@
|
|||
! Copyright (C) 2007, 2008 Phil Dawes
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
! Simple CSV Parser
|
||||
! Phil Dawes phil@phildawes.net
|
||||
|
||||
USING: kernel sequences io namespaces combinators
|
||||
unicode.categories ;
|
||||
IN: csv
|
||||
|
||||
DEFER: quoted-field
|
||||
|
||||
: not-quoted-field ( -- endchar )
|
||||
",\"\n" read-until ! "
|
||||
dup
|
||||
{ { CHAR: " [ drop drop quoted-field ] } ! "
|
||||
{ CHAR: , [ swap % ] }
|
||||
{ CHAR: \n [ swap % ] }
|
||||
{ f [ swap % ] } ! eof
|
||||
} case ;
|
||||
|
||||
: maybe-escaped-quote ( -- endchar )
|
||||
read1
|
||||
dup
|
||||
{ { CHAR: " [ , quoted-field ] } ! " is an escaped quote
|
||||
{ CHAR: \s [ drop not-quoted-field ] }
|
||||
{ CHAR: \t [ drop not-quoted-field ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
|
||||
! trims whitespace from either end of string
|
||||
: trim-whitespace ( str -- str )
|
||||
[ blank? ] trim ; inline
|
||||
|
||||
: quoted-field ( -- endchar )
|
||||
"\"" read-until ! "
|
||||
drop % maybe-escaped-quote ;
|
||||
|
||||
: field ( -- sep string )
|
||||
[ not-quoted-field ] "" make trim-whitespace ;
|
||||
|
||||
: (row) ( -- sep )
|
||||
field ,
|
||||
dup CHAR: , = [ drop (row) ] when ;
|
||||
|
||||
: row ( -- eof? array[string] )
|
||||
[ (row) ] { } make ;
|
||||
|
||||
: append-if-row-not-empty ( row -- )
|
||||
dup { "" } = [ drop ] [ , ] if ;
|
||||
|
||||
: (csv) ( -- )
|
||||
row append-if-row-not-empty
|
||||
[ (csv) ] when ;
|
||||
|
||||
: csv-row ( stream -- row )
|
||||
[ row nip ] with-stream ;
|
||||
|
||||
: csv ( stream -- rows )
|
||||
[ [ (csv) ] { } make ] with-stream ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
CSV parser
|
||||
|
|
@ -35,7 +35,6 @@ HOOK: db-close db ( handle -- )
|
|||
handle>> db-close
|
||||
] with-variable ;
|
||||
|
||||
! TUPLE: sql sql in-params out-params ;
|
||||
TUPLE: statement handle sql in-params out-params bind-params bound? type ;
|
||||
TUPLE: simple-statement < statement ;
|
||||
TUPLE: prepared-statement < statement ;
|
||||
|
|
|
|||
|
|
@ -154,7 +154,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
|
|||
: postgresql-column-typed ( handle row column type -- obj )
|
||||
dup array? [ first ] when
|
||||
{
|
||||
{ +native-id+ [ pq-get-number ] }
|
||||
{ +db-assigned-id+ [ pq-get-number ] }
|
||||
{ +random-id+ [ pq-get-number ] }
|
||||
{ INTEGER [ pq-get-number ] }
|
||||
{ BIG-INTEGER [ pq-get-number ] }
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ sequences debugger db db.postgresql.lib db.postgresql.ffi
|
|||
db.tuples db.types tools.annotations math.ranges
|
||||
combinators sequences.lib classes locals words tools.walker
|
||||
namespaces.lib accessors random db.queries ;
|
||||
USE: tools.walker
|
||||
IN: db.postgresql
|
||||
|
||||
TUPLE: postgresql-db < db
|
||||
|
|
@ -48,7 +49,8 @@ M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- obj )
|
|||
nip value>> <low-level-binding> ;
|
||||
|
||||
M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- obj )
|
||||
nip singleton>> eval-generator <low-level-binding> ;
|
||||
dup generator-singleton>> eval-generator
|
||||
[ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
|
||||
|
||||
M: postgresql-statement bind-tuple ( tuple statement -- )
|
||||
tuck in-params>>
|
||||
|
|
@ -158,7 +160,7 @@ M: postgresql-db bind# ( spec obj -- )
|
|||
M: postgresql-db create-sql-statement ( class -- seq )
|
||||
[
|
||||
[ create-table-sql , ] keep
|
||||
dup db-columns find-primary-key native-id?
|
||||
dup db-columns find-primary-key db-assigned-id-spec?
|
||||
[ create-function-sql , ] [ drop ] if
|
||||
] { } make ;
|
||||
|
||||
|
|
@ -179,11 +181,11 @@ M: postgresql-db create-sql-statement ( class -- seq )
|
|||
M: postgresql-db drop-sql-statement ( class -- seq )
|
||||
[
|
||||
[ drop-table-sql , ] keep
|
||||
dup db-columns find-primary-key native-id?
|
||||
dup db-columns find-primary-key db-assigned-id-spec?
|
||||
[ drop-function-sql , ] [ drop ] if
|
||||
] { } make ;
|
||||
|
||||
M: postgresql-db <insert-native-statement> ( class -- statement )
|
||||
M: postgresql-db <insert-db-assigned-statement> ( class -- statement )
|
||||
[
|
||||
"select add_" 0% 0%
|
||||
"(" 0%
|
||||
|
|
@ -193,7 +195,7 @@ M: postgresql-db <insert-native-statement> ( class -- statement )
|
|||
");" 0%
|
||||
] query-make ;
|
||||
|
||||
M: postgresql-db <insert-nonnative-statement> ( class -- statement )
|
||||
M: postgresql-db <insert-user-assigned-statement> ( class -- statement )
|
||||
[
|
||||
"insert into " 0% 0%
|
||||
"(" 0%
|
||||
|
|
@ -204,8 +206,10 @@ M: postgresql-db <insert-nonnative-statement> ( class -- statement )
|
|||
[ ", " 0% ] [
|
||||
dup type>> +random-id+ = [
|
||||
[
|
||||
drop bind-name%
|
||||
f random-id-generator
|
||||
bind-name%
|
||||
slot-name>>
|
||||
f
|
||||
random-id-generator
|
||||
] [ type>> ] bi <generator-bind> 1,
|
||||
] [
|
||||
bind%
|
||||
|
|
@ -219,8 +223,8 @@ M: postgresql-db insert-tuple* ( tuple statement -- )
|
|||
|
||||
M: postgresql-db persistent-table ( -- hashtable )
|
||||
H{
|
||||
{ +native-id+ { "integer" "serial primary key" f } }
|
||||
{ +assigned-id+ { f f "primary key" } }
|
||||
{ +db-assigned-id+ { "integer" "serial primary key" f } }
|
||||
{ +user-assigned-id+ { f f "primary key" } }
|
||||
{ +random-id+ { "bigint" "bigint primary key" f } }
|
||||
{ TEXT { "text" "text" f } }
|
||||
{ VARCHAR { "varchar" "varchar" f } }
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ GENERIC: where ( specs obj -- )
|
|||
|
||||
: query-make ( class quot -- )
|
||||
>r sql-props r>
|
||||
[ 0 sql-counter rot with-variable ] { "" { } { } } nmake
|
||||
[ 0 sql-counter rot with-variable ";" 0% ] { "" { } { } } nmake
|
||||
<simple-statement> maybe-make-retryable ; inline
|
||||
|
||||
M: db begin-transaction ( -- ) "BEGIN" sql-command ;
|
||||
|
|
@ -35,14 +35,6 @@ M: db <update-tuple-statement> ( class -- statement )
|
|||
where-primary-key%
|
||||
] query-make ;
|
||||
|
||||
M: db <delete-tuple-statement> ( specs table -- sql )
|
||||
[
|
||||
"delete from " 0% 0%
|
||||
" where " 0%
|
||||
find-primary-key
|
||||
dup column-name>> 0% " = " 0% bind%
|
||||
] query-make ;
|
||||
|
||||
M: random-id-generator eval-generator ( singleton -- obj )
|
||||
drop
|
||||
system-random-generator get [
|
||||
|
|
@ -52,18 +44,40 @@ M: random-id-generator eval-generator ( singleton -- obj )
|
|||
: interval-comparison ( ? str -- str )
|
||||
"from" = " >" " <" ? swap [ "= " append ] when ;
|
||||
|
||||
: fp-infinity? ( float -- ? )
|
||||
dup float? [
|
||||
double>bits -52 shift 11 2^ 1- [ bitand ] keep =
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: (infinite-interval?) ( interval -- ?1 ?2 )
|
||||
[ from>> ] [ to>> ] bi
|
||||
[ first fp-infinity? ] bi@ ;
|
||||
|
||||
: double-infinite-interval? ( obj -- ? )
|
||||
dup interval? [ (infinite-interval?) and ] [ drop f ] if ;
|
||||
|
||||
: infinite-interval? ( obj -- ? )
|
||||
dup interval? [ (infinite-interval?) or ] [ drop f ] if ;
|
||||
|
||||
: where-interval ( spec obj from/to -- )
|
||||
pick column-name>> 0%
|
||||
>r first2 r> interval-comparison 0%
|
||||
bind# ;
|
||||
over first fp-infinity? [
|
||||
3drop
|
||||
] [
|
||||
pick column-name>> 0%
|
||||
>r first2 r> interval-comparison 0%
|
||||
bind#
|
||||
] if ;
|
||||
|
||||
: in-parens ( quot -- )
|
||||
"(" 0% call ")" 0% ; inline
|
||||
|
||||
M: interval where ( spec obj -- )
|
||||
[
|
||||
[ from>> "from" where-interval " and " 0% ]
|
||||
[ to>> "to" where-interval ] 2bi
|
||||
[ from>> "from" where-interval ] [
|
||||
nip infinite-interval? [ " and " 0% ] unless
|
||||
] [ to>> "to" where-interval ] 2tri
|
||||
] in-parens ;
|
||||
|
||||
M: sequence where ( spec obj -- )
|
||||
|
|
@ -80,12 +94,29 @@ M: integer where ( spec obj -- ) object-where ;
|
|||
|
||||
M: string where ( spec obj -- ) object-where ;
|
||||
|
||||
: filter-slots ( tuple specs -- specs' )
|
||||
[
|
||||
slot-name>> swap get-slot-named
|
||||
dup double-infinite-interval? [ drop f ] when
|
||||
] with filter ;
|
||||
|
||||
: where-clause ( tuple specs -- )
|
||||
" where " 0% [
|
||||
" and " 0%
|
||||
dupd filter-slots
|
||||
dup empty? [
|
||||
2drop
|
||||
] [
|
||||
2dup slot-name>> swap get-slot-named where
|
||||
] interleave drop ;
|
||||
" where " 0% [
|
||||
" and " 0%
|
||||
] [
|
||||
2dup slot-name>> swap get-slot-named where
|
||||
] interleave drop
|
||||
] if ;
|
||||
|
||||
M: db <delete-tuples-statement> ( tuple table -- sql )
|
||||
[
|
||||
"delete from " 0% 0%
|
||||
where-clause
|
||||
] query-make ;
|
||||
|
||||
M: db <select-by-slots-statement> ( tuple class -- statement )
|
||||
[
|
||||
|
|
@ -94,7 +125,5 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
|
|||
[ dup column-name>> 0% 2, ] interleave
|
||||
|
||||
" from " 0% 0%
|
||||
dupd
|
||||
[ slot-name>> swap get-slot-named ] with filter
|
||||
dup empty? [ 2drop ] [ where-clause ] if ";" 0%
|
||||
where-clause
|
||||
] query-make ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
USING: kernel parser quotations classes.tuple words math.order
|
||||
namespaces.lib namespaces sequences arrays combinators
|
||||
prettyprint strings math.parser sequences.lib math symbols ;
|
||||
USE: tools.walker
|
||||
IN: db.sql
|
||||
|
||||
SYMBOLS: insert update delete select distinct columns from as
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: alien.c-types arrays assocs kernel math math.parser
|
|||
namespaces sequences db.sqlite.ffi db combinators
|
||||
continuations db.types calendar.format serialize
|
||||
io.streams.byte-array byte-arrays io.encodings.binary
|
||||
tools.walker io.backend ;
|
||||
io.backend ;
|
||||
IN: db.sqlite.lib
|
||||
|
||||
: sqlite-error ( n -- * )
|
||||
|
|
@ -106,7 +106,7 @@ IN: db.sqlite.lib
|
|||
object>bytes
|
||||
sqlite-bind-blob-by-name
|
||||
] }
|
||||
{ +native-id+ [ sqlite-bind-int-by-name ] }
|
||||
{ +db-assigned-id+ [ sqlite-bind-int-by-name ] }
|
||||
{ +random-id+ [ sqlite-bind-int64-by-name ] }
|
||||
{ NULL [ sqlite-bind-null-by-name ] }
|
||||
[ no-sql-type ]
|
||||
|
|
@ -132,7 +132,7 @@ IN: db.sqlite.lib
|
|||
: sqlite-column-typed ( handle index type -- obj )
|
||||
dup array? [ first ] when
|
||||
{
|
||||
{ +native-id+ [ sqlite3_column_int64 ] }
|
||||
{ +db-assigned-id+ [ sqlite3_column_int64 ] }
|
||||
{ +random-id+ [ sqlite3-column-uint64 ] }
|
||||
{ INTEGER [ sqlite3_column_int ] }
|
||||
{ BIG-INTEGER [ sqlite3_column_int64 ] }
|
||||
|
|
|
|||
|
|
@ -79,8 +79,10 @@ M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
|
|||
<sqlite-low-level-binding> ;
|
||||
|
||||
M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
|
||||
nip [ key>> ] [ singleton>> eval-generator ] [ type>> ] tri
|
||||
<sqlite-low-level-binding> ;
|
||||
tuck
|
||||
[ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi
|
||||
rot set-slot-named
|
||||
>r [ key>> ] [ type>> ] bi r> swap <sqlite-low-level-binding> ;
|
||||
|
||||
M: sqlite-statement bind-tuple ( tuple statement -- )
|
||||
[
|
||||
|
|
@ -129,19 +131,20 @@ M: sqlite-db create-sql-statement ( class -- statement )
|
|||
M: sqlite-db drop-sql-statement ( class -- statement )
|
||||
[ "drop table " 0% 0% ";" 0% drop ] query-make ;
|
||||
|
||||
M: sqlite-db <insert-native-statement> ( tuple -- statement )
|
||||
M: sqlite-db <insert-db-assigned-statement> ( tuple -- statement )
|
||||
[
|
||||
"insert into " 0% 0%
|
||||
"(" 0%
|
||||
maybe-remove-id
|
||||
remove-db-assigned-id
|
||||
dup [ ", " 0% ] [ column-name>> 0% ] interleave
|
||||
") values(" 0%
|
||||
[ ", " 0% ] [
|
||||
dup type>> +random-id+ = [
|
||||
[ slot-name>> ]
|
||||
[
|
||||
column-name>> ":" prepend dup 0%
|
||||
random-id-generator
|
||||
] [ type>> ] bi <generator-bind> 1,
|
||||
] [ type>> ] tri <generator-bind> 1,
|
||||
] [
|
||||
bind%
|
||||
] if
|
||||
|
|
@ -149,8 +152,8 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
|
|||
");" 0%
|
||||
] query-make ;
|
||||
|
||||
M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
|
||||
<insert-native-statement> ;
|
||||
M: sqlite-db <insert-user-assigned-statement> ( tuple -- statement )
|
||||
<insert-db-assigned-statement> ;
|
||||
|
||||
M: sqlite-db bind# ( spec obj -- )
|
||||
>r
|
||||
|
|
@ -163,8 +166,8 @@ M: sqlite-db bind% ( spec -- )
|
|||
|
||||
M: sqlite-db persistent-table ( -- assoc )
|
||||
H{
|
||||
{ +native-id+ { "integer primary key" "integer primary key" "primary key" } }
|
||||
{ +assigned-id+ { f f "primary key" } }
|
||||
{ +db-assigned-id+ { "integer primary key" "integer primary key" "primary key" } }
|
||||
{ +user-assigned-id+ { f f "primary key" } }
|
||||
{ +random-id+ { "integer primary key" "integer primary key" "primary key" } }
|
||||
{ INTEGER { "integer" "integer" "primary key" } }
|
||||
{ BIG-INTEGER { "bigint" "bigint" } }
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.files kernel tools.test db db.tuples classes
|
||||
db.types continuations namespaces math math.ranges
|
||||
prettyprint tools.walker calendar sequences db.sqlite
|
||||
math.intervals db.postgresql accessors random math.bitfields.lib ;
|
||||
prettyprint calendar sequences db.sqlite math.intervals
|
||||
db.postgresql accessors random math.bitfields.lib ;
|
||||
IN: db.tuples.tests
|
||||
|
||||
TUPLE: person the-id the-name the-number the-real
|
||||
|
|
@ -21,7 +21,7 @@ ts date time blob factor-blob ;
|
|||
set-person-factor-blob
|
||||
} person construct ;
|
||||
|
||||
: <assigned-person> ( id name age real ts date time blob factor-blob -- person )
|
||||
: <user-assigned-person> ( id name age real ts date time blob factor-blob -- person )
|
||||
<person> [ set-person-the-id ] keep ;
|
||||
|
||||
SYMBOL: person1
|
||||
|
|
@ -30,6 +30,7 @@ SYMBOL: person3
|
|||
SYMBOL: person4
|
||||
|
||||
: test-tuples ( -- )
|
||||
[ ] [ person recreate-table ] unit-test
|
||||
[ ] [ person ensure-table ] unit-test
|
||||
[ ] [ person drop-table ] unit-test
|
||||
[ ] [ person create-table ] unit-test
|
||||
|
|
@ -67,7 +68,7 @@ SYMBOL: person4
|
|||
] [ T{ person f f f 10 3.14 } select-tuples ] unit-test
|
||||
|
||||
|
||||
[ ] [ person1 get delete-tuple ] unit-test
|
||||
[ ] [ person1 get delete-tuples ] unit-test
|
||||
[ f ] [ T{ person f 1 } select-tuple ] unit-test
|
||||
|
||||
[ ] [ person3 get insert-tuple ] unit-test
|
||||
|
|
@ -106,10 +107,10 @@ SYMBOL: person4
|
|||
|
||||
[ ] [ person drop-table ] unit-test ;
|
||||
|
||||
: native-person-schema ( -- )
|
||||
: db-assigned-person-schema ( -- )
|
||||
person "PERSON"
|
||||
{
|
||||
{ "the-id" "ID" +native-id+ }
|
||||
{ "the-id" "ID" +db-assigned-id+ }
|
||||
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
|
||||
{ "the-number" "AGE" INTEGER { +default+ 0 } }
|
||||
{ "the-real" "REAL" DOUBLE { +default+ 0.3 } }
|
||||
|
|
@ -132,10 +133,10 @@ SYMBOL: person4
|
|||
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
|
||||
f H{ { 1 2 } { 3 4 } { 5 "lol" } } <person> person4 set ;
|
||||
|
||||
: assigned-person-schema ( -- )
|
||||
: user-assigned-person-schema ( -- )
|
||||
person "PERSON"
|
||||
{
|
||||
{ "the-id" "ID" INTEGER +assigned-id+ }
|
||||
{ "the-id" "ID" INTEGER +user-assigned-id+ }
|
||||
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
|
||||
{ "the-number" "AGE" INTEGER { +default+ 0 } }
|
||||
{ "the-real" "REAL" DOUBLE { +default+ 0.3 } }
|
||||
|
|
@ -145,27 +146,27 @@ SYMBOL: person4
|
|||
{ "blob" "B" BLOB }
|
||||
{ "factor-blob" "FB" FACTOR-BLOB }
|
||||
} define-persistent
|
||||
1 "billy" 10 3.14 f f f f f <assigned-person> person1 set
|
||||
2 "johnny" 10 3.14 f f f f f <assigned-person> person2 set
|
||||
1 "billy" 10 3.14 f f f f f <user-assigned-person> person1 set
|
||||
2 "johnny" 10 3.14 f f f f f <user-assigned-person> person2 set
|
||||
3 "teddy" 10 3.14
|
||||
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
|
||||
B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
|
||||
f <assigned-person> person3 set
|
||||
f <user-assigned-person> person3 set
|
||||
4 "eddie" 10 3.14
|
||||
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
|
||||
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
|
||||
f H{ { 1 2 } { 3 4 } { 5 "lol" } } <assigned-person> person4 set ;
|
||||
f H{ { 1 2 } { 3 4 } { 5 "lol" } } <user-assigned-person> person4 set ;
|
||||
|
||||
TUPLE: paste n summary author channel mode contents timestamp annotations ;
|
||||
TUPLE: annotation n paste-id summary author mode contents ;
|
||||
|
||||
: native-paste-schema ( -- )
|
||||
: db-assigned-paste-schema ( -- )
|
||||
paste "PASTE"
|
||||
{
|
||||
{ "n" "ID" +native-id+ }
|
||||
{ "n" "ID" +db-assigned-id+ }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
{ "channel" "CHANNEL" TEXT }
|
||||
|
|
@ -177,7 +178,7 @@ TUPLE: annotation n paste-id summary author mode contents ;
|
|||
|
||||
annotation "ANNOTATION"
|
||||
{
|
||||
{ "n" "ID" +native-id+ }
|
||||
{ "n" "ID" +db-assigned-id+ }
|
||||
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } }
|
||||
{ "summary" "SUMMARY" TEXT }
|
||||
{ "author" "AUTHOR" TEXT }
|
||||
|
|
@ -210,7 +211,7 @@ TUPLE: serialize-me id data ;
|
|||
: test-serialize ( -- )
|
||||
serialize-me "SERIALIZED"
|
||||
{
|
||||
{ "id" "ID" +native-id+ }
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
{ "data" "DATA" FACTOR-BLOB }
|
||||
} define-persistent
|
||||
[ serialize-me drop-table ] [ drop ] recover
|
||||
|
|
@ -226,7 +227,7 @@ TUPLE: exam id name score ;
|
|||
: test-intervals ( -- )
|
||||
exam "EXAM"
|
||||
{
|
||||
{ "id" "ID" +native-id+ }
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
{ "name" "NAME" TEXT }
|
||||
{ "score" "SCORE" INTEGER }
|
||||
} define-persistent
|
||||
|
|
@ -292,6 +293,46 @@ TUPLE: exam id name score ;
|
|||
}
|
||||
] [
|
||||
T{ exam f T{ range f 1 3 1 } } select-tuples
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ exam f 2 "Stan" 80 }
|
||||
T{ exam f 3 "Kenny" 60 }
|
||||
T{ exam f 4 "Cartman" 41 }
|
||||
}
|
||||
] [
|
||||
T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ exam f 1 "Kyle" 100 }
|
||||
}
|
||||
] [
|
||||
T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ exam f 1 "Kyle" 100 }
|
||||
T{ exam f 2 "Stan" 80 }
|
||||
T{ exam f 3 "Kenny" 60 }
|
||||
T{ exam f 4 "Cartman" 41 }
|
||||
}
|
||||
] [
|
||||
T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ exam f 1 "Kyle" 100 }
|
||||
T{ exam f 2 "Stan" 80 }
|
||||
T{ exam f 3 "Kenny" 60 }
|
||||
T{ exam f 4 "Cartman" 41 }
|
||||
}
|
||||
] [
|
||||
T{ exam } select-tuples
|
||||
] unit-test ;
|
||||
|
||||
TUPLE: bignum-test id m n o ;
|
||||
|
|
@ -304,7 +345,7 @@ TUPLE: bignum-test id m n o ;
|
|||
: test-bignum
|
||||
bignum-test "BIGNUM_TEST"
|
||||
{
|
||||
{ "id" "ID" +native-id+ }
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
{ "m" "M" BIG-INTEGER }
|
||||
{ "n" "N" UNSIGNED-BIG-INTEGER }
|
||||
{ "o" "O" SIGNED-BIG-INTEGER }
|
||||
|
|
@ -328,9 +369,9 @@ C: <secret> secret
|
|||
{ "message" "MESSAGE" TEXT }
|
||||
} define-persistent
|
||||
|
||||
[ ] [ secret ensure-table ] unit-test
|
||||
[ ] [ secret recreate-table ] unit-test
|
||||
|
||||
[ ] [ f "kilroy was here" <secret> insert-tuple ] unit-test
|
||||
[ t ] [ f "kilroy was here" <secret> [ insert-tuple ] keep n>> integer? ] unit-test
|
||||
|
||||
[ ] [ f "kilroy was here2" <secret> insert-tuple ] unit-test
|
||||
|
||||
|
|
@ -345,17 +386,17 @@ C: <secret> secret
|
|||
T{ secret } select-tuples length 3 =
|
||||
] unit-test ;
|
||||
|
||||
[ native-person-schema test-tuples ] test-sqlite
|
||||
[ assigned-person-schema test-tuples ] test-sqlite
|
||||
[ assigned-person-schema test-repeated-insert ] test-sqlite
|
||||
[ db-assigned-person-schema test-tuples ] test-sqlite
|
||||
[ user-assigned-person-schema test-tuples ] test-sqlite
|
||||
[ user-assigned-person-schema test-repeated-insert ] test-sqlite
|
||||
[ test-bignum ] test-sqlite
|
||||
[ test-serialize ] test-sqlite
|
||||
[ test-intervals ] test-sqlite
|
||||
[ test-random-id ] test-sqlite
|
||||
|
||||
[ native-person-schema test-tuples ] test-postgresql
|
||||
[ assigned-person-schema test-tuples ] test-postgresql
|
||||
[ assigned-person-schema test-repeated-insert ] test-postgresql
|
||||
[ db-assigned-person-schema test-tuples ] test-postgresql
|
||||
[ user-assigned-person-schema test-tuples ] test-postgresql
|
||||
[ user-assigned-person-schema test-repeated-insert ] test-postgresql
|
||||
[ test-bignum ] test-postgresql
|
||||
[ test-serialize ] test-postgresql
|
||||
[ test-intervals ] test-postgresql
|
||||
|
|
@ -377,7 +418,7 @@ TUPLE: does-not-persist ;
|
|||
\ bind-tuple must-infer
|
||||
\ insert-tuple must-infer
|
||||
\ update-tuple must-infer
|
||||
\ delete-tuple must-infer
|
||||
\ delete-tuples must-infer
|
||||
\ select-tuple must-infer
|
||||
\ define-persistent must-infer
|
||||
\ ensure-table must-infer
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: arrays assocs classes db kernel namespaces
|
||||
classes.tuple words sequences slots math accessors
|
||||
math.parser io prettyprint db.types continuations
|
||||
mirrors sequences.lib tools.walker combinators.lib ;
|
||||
mirrors sequences.lib combinators.lib ;
|
||||
IN: db.tuples
|
||||
|
||||
: define-persistent ( class table columns -- )
|
||||
|
|
@ -37,15 +37,10 @@ SYMBOL: sql-counter
|
|||
HOOK: create-sql-statement db ( class -- obj )
|
||||
HOOK: drop-sql-statement db ( class -- obj )
|
||||
|
||||
HOOK: <insert-native-statement> db ( class -- obj )
|
||||
HOOK: <insert-nonnative-statement> db ( class -- obj )
|
||||
|
||||
HOOK: <insert-db-assigned-statement> db ( class -- obj )
|
||||
HOOK: <insert-user-assigned-statement> db ( class -- obj )
|
||||
HOOK: <update-tuple-statement> db ( class -- obj )
|
||||
HOOK: <update-tuples-statement> db ( class -- obj )
|
||||
|
||||
HOOK: <delete-tuple-statement> db ( class -- obj )
|
||||
HOOK: <delete-tuples-statement> db ( class -- obj )
|
||||
|
||||
HOOK: <delete-tuples-statement> db ( tuple class -- obj )
|
||||
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
|
||||
|
||||
HOOK: insert-tuple* db ( tuple statement -- )
|
||||
|
|
@ -65,7 +60,7 @@ SINGLETON: retryable
|
|||
[ bind-params>> ] [ in-params>> ] bi
|
||||
[
|
||||
dup generator-bind? [
|
||||
singleton>> eval-generator >>value
|
||||
generator-singleton>> eval-generator >>value
|
||||
] [
|
||||
drop
|
||||
] if
|
||||
|
|
@ -113,35 +108,38 @@ M: retryable execute-statement* ( statement type -- )
|
|||
: drop-table ( class -- )
|
||||
drop-sql-statement [ execute-statement ] with-disposals ;
|
||||
|
||||
: ensure-table ( class -- )
|
||||
: recreate-table ( class -- )
|
||||
[
|
||||
drop-sql-statement make-nonthrowable
|
||||
[ execute-statement ] with-disposals
|
||||
] [ create-table ] bi ;
|
||||
|
||||
: insert-native ( tuple -- )
|
||||
: ensure-table ( class -- )
|
||||
[ create-table ] curry ignore-errors ;
|
||||
|
||||
: insert-db-assigned-statement ( tuple -- )
|
||||
dup class
|
||||
db get db-insert-statements [ <insert-native-statement> ] cache
|
||||
db get db-insert-statements [ <insert-db-assigned-statement> ] cache
|
||||
[ bind-tuple ] 2keep insert-tuple* ;
|
||||
|
||||
: insert-nonnative ( tuple -- )
|
||||
: insert-user-assigned-statement ( tuple -- )
|
||||
dup class
|
||||
db get db-insert-statements [ <insert-nonnative-statement> ] cache
|
||||
db get db-insert-statements [ <insert-user-assigned-statement> ] cache
|
||||
[ bind-tuple ] keep execute-statement ;
|
||||
|
||||
: insert-tuple ( tuple -- )
|
||||
dup class db-columns find-primary-key nonnative-id?
|
||||
[ insert-nonnative ] [ insert-native ] if ;
|
||||
dup class db-columns find-primary-key db-assigned-id-spec?
|
||||
[ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
|
||||
|
||||
: update-tuple ( tuple -- )
|
||||
dup class
|
||||
db get db-update-statements [ <update-tuple-statement> ] cache
|
||||
[ bind-tuple ] keep execute-statement ;
|
||||
|
||||
: delete-tuple ( tuple -- )
|
||||
dup class
|
||||
db get db-delete-statements [ <delete-tuple-statement> ] cache
|
||||
[ bind-tuple ] keep execute-statement ;
|
||||
: delete-tuples ( tuple -- )
|
||||
dup dup class <delete-tuples-statement> [
|
||||
[ bind-tuple ] keep execute-statement
|
||||
] with-disposal ;
|
||||
|
||||
: select-tuples ( tuple -- tuples )
|
||||
dup dup class <select-by-slots-statement> [
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs db kernel math math.parser
|
||||
sequences continuations sequences.deep sequences.lib
|
||||
words namespaces tools.walker slots slots.private classes
|
||||
mirrors classes.tuple combinators calendar.format symbols
|
||||
words namespaces slots slots.private classes mirrors
|
||||
classes.tuple combinators calendar.format symbols
|
||||
classes.singleton accessors quotations random ;
|
||||
IN: db.types
|
||||
|
||||
|
|
@ -15,18 +15,17 @@ TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
|
|||
TUPLE: literal-bind key type value ;
|
||||
C: <literal-bind> literal-bind
|
||||
|
||||
TUPLE: generator-bind key singleton type ;
|
||||
TUPLE: generator-bind slot-name key generator-singleton type ;
|
||||
C: <generator-bind> generator-bind
|
||||
SINGLETON: random-id-generator
|
||||
|
||||
TUPLE: low-level-binding value ;
|
||||
C: <low-level-binding> low-level-binding
|
||||
|
||||
SINGLETON: +native-id+
|
||||
SINGLETON: +assigned-id+
|
||||
SINGLETON: +db-assigned-id+
|
||||
SINGLETON: +user-assigned-id+
|
||||
SINGLETON: +random-id+
|
||||
UNION: +primary-key+ +native-id+ +assigned-id+ +random-id+ ;
|
||||
UNION: +nonnative-id+ +random-id+ +assigned-id+ ;
|
||||
UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
|
||||
|
||||
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
|
||||
+foreign-id+ +has-many+ ;
|
||||
|
|
@ -43,11 +42,11 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
|
|||
: primary-key? ( spec -- ? )
|
||||
primary-key>> +primary-key+? ;
|
||||
|
||||
: native-id? ( spec -- ? )
|
||||
primary-key>> +native-id+? ;
|
||||
: db-assigned-id-spec? ( spec -- ? )
|
||||
primary-key>> +db-assigned-id+? ;
|
||||
|
||||
: nonnative-id? ( spec -- ? )
|
||||
primary-key>> +nonnative-id+? ;
|
||||
: assigned-id-spec? ( spec -- ? )
|
||||
primary-key>> +user-assigned-id+? ;
|
||||
|
||||
: normalize-spec ( spec -- )
|
||||
dup type>> dup +primary-key+? [
|
||||
|
|
@ -82,8 +81,8 @@ FACTOR-BLOB NULL ;
|
|||
: number>string* ( n/str -- str )
|
||||
dup number? [ number>string ] when ;
|
||||
|
||||
: maybe-remove-id ( specs -- obj )
|
||||
[ +native-id+? not ] filter ;
|
||||
: remove-db-assigned-id ( specs -- obj )
|
||||
[ +db-assigned-id+? not ] filter ;
|
||||
|
||||
: remove-relations ( specs -- newcolumns )
|
||||
[ relation? not ] filter ;
|
||||
|
|
|
|||
|
|
@ -104,6 +104,7 @@ $nl
|
|||
ARTICLE: "objects" "Objects"
|
||||
"An " { $emphasis "object" } " is any datum which may be identified. All values are objects in Factor. Each object carries type information, and types are checked at runtime; Factor is dynamically typed."
|
||||
{ $subsection "equality" }
|
||||
{ $subsection "math.order" }
|
||||
{ $subsection "classes" }
|
||||
{ $subsection "tuples" }
|
||||
{ $subsection "generic" }
|
||||
|
|
|
|||
|
|
@ -113,7 +113,7 @@ ARTICLE: "help" "Help system"
|
|||
"The help system maintains documentation written in a simple markup language, along with cross-referencing and search. Documentation can either exist as free-standing " { $emphasis "articles" } " or be associated with words."
|
||||
{ $subsection "browsing-help" }
|
||||
{ $subsection "writing-help" }
|
||||
{ $subsection "help.lint" }
|
||||
{ $vocab-subsection "Help lint tool" "help.lint" }
|
||||
{ $subsection "help-impl" } ;
|
||||
|
||||
IN: help
|
||||
|
|
|
|||
|
|
@ -134,8 +134,7 @@ read-response-test-1' 1array [
|
|||
|
||||
! Live-fire exercise
|
||||
USING: http.server http.server.static http.server.sessions
|
||||
http.server.sessions.storage.db http.server.actions
|
||||
http.server.auth.login http.server.db http.client
|
||||
http.server.actions http.server.auth.login http.server.db http.client
|
||||
io.server io.files io io.encodings.ascii
|
||||
accessors namespaces threads ;
|
||||
|
||||
|
|
@ -194,8 +193,7 @@ test-db [
|
|||
<dispatcher>
|
||||
<action> <protected>
|
||||
<login>
|
||||
<session-manager>
|
||||
sessions-in-db >>sessions
|
||||
<sessions>
|
||||
"" add-responder
|
||||
add-quit-action
|
||||
<dispatcher>
|
||||
|
|
@ -225,8 +223,7 @@ test-db [
|
|||
<dispatcher>
|
||||
<action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
|
||||
<login>
|
||||
<session-manager>
|
||||
sessions-in-db >>sessions
|
||||
<sessions>
|
||||
"" add-responder
|
||||
add-quit-action
|
||||
test-db <db-persistence>
|
||||
|
|
|
|||
|
|
@ -329,7 +329,8 @@ SYMBOL: max-post-request
|
|||
[ host>> ] [ port>> ] bi <inet> ;
|
||||
|
||||
: request-host ( request -- string )
|
||||
[ host>> ] [ drop ":" ] [ port>> number>string ] tri 3append ;
|
||||
[ host>> ] [ port>> ] bi
|
||||
dup 80 = [ drop ] [ ":" swap number>string 3append ] if ;
|
||||
|
||||
: write-request-header ( request -- request )
|
||||
dup header>> >hashtable
|
||||
|
|
|
|||
|
|
@ -0,0 +1,152 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences accessors namespaces combinators
|
||||
locals db.tuples
|
||||
http.server.templating.chloe
|
||||
http.server.boilerplate
|
||||
http.server.auth.providers
|
||||
http.server.auth.providers.db
|
||||
http.server.auth.login
|
||||
http.server.forms
|
||||
http.server.components.inspector
|
||||
http.server.components
|
||||
http.server.validators
|
||||
http.server.sessions
|
||||
http.server.actions
|
||||
http.server.crud
|
||||
http.server ;
|
||||
IN: http.server.auth.admin
|
||||
|
||||
: admin-template ( name -- template )
|
||||
"resource:extra/http/server/auth/admin/" swap ".xml" 3append <chloe> ;
|
||||
|
||||
: <new-user-form> ( -- form )
|
||||
"user" <form>
|
||||
"new-user" admin-template >>edit-template
|
||||
"username" <string> add-field
|
||||
"realname" <string> add-field
|
||||
"new-password" <password> t >>required add-field
|
||||
"verify-password" <password> t >>required add-field
|
||||
"email" <email> add-field ;
|
||||
|
||||
: <edit-user-form> ( -- form )
|
||||
"user" <form>
|
||||
"edit-user" admin-template >>edit-template
|
||||
"user-summary" admin-template >>summary-template
|
||||
"username" <string> hidden >>renderer add-field
|
||||
"realname" <string> add-field
|
||||
"new-password" <password> add-field
|
||||
"verify-password" <password> add-field
|
||||
"email" <email> add-field
|
||||
"profile" <inspector> add-field ;
|
||||
|
||||
: <user-list-form> ( -- form )
|
||||
"user-list" <form>
|
||||
"user-list" admin-template >>view-template
|
||||
"list" <edit-user-form> +unordered+ <list> add-field ;
|
||||
|
||||
:: <new-user-action> ( form ctor next -- action )
|
||||
<action>
|
||||
[
|
||||
blank-values
|
||||
|
||||
"username" get ctor call
|
||||
|
||||
{
|
||||
[ username>> "username" set-value ]
|
||||
[ realname>> "realname" set-value ]
|
||||
[ email>> "email" set-value ]
|
||||
[ profile>> "profile" set-value ]
|
||||
} cleave
|
||||
] >>init
|
||||
|
||||
[ form edit-form ] >>display
|
||||
|
||||
[
|
||||
blank-values
|
||||
|
||||
form validate-form
|
||||
|
||||
same-password-twice
|
||||
|
||||
user new "username" value >>username select-tuple [
|
||||
user-exists? on
|
||||
validation-failed
|
||||
] when
|
||||
|
||||
"username" value <user>
|
||||
"realname" value >>realname
|
||||
"email" value >>email
|
||||
"new-password" value >>password
|
||||
H{ } clone >>profile
|
||||
|
||||
insert-tuple
|
||||
|
||||
next f <standard-redirect>
|
||||
] >>submit ;
|
||||
|
||||
:: <edit-user-action> ( form ctor next -- action )
|
||||
<action>
|
||||
{ { "username" [ v-required ] } } >>get-params
|
||||
|
||||
[
|
||||
blank-values
|
||||
|
||||
"username" get ctor call select-tuple
|
||||
|
||||
{
|
||||
[ username>> "username" set-value ]
|
||||
[ realname>> "realname" set-value ]
|
||||
[ email>> "email" set-value ]
|
||||
[ profile>> "profile" set-value ]
|
||||
} cleave
|
||||
] >>init
|
||||
|
||||
[ form edit-form ] >>display
|
||||
|
||||
[
|
||||
blank-values
|
||||
|
||||
form validate-form
|
||||
|
||||
"username" value <user> select-tuple
|
||||
"realname" value >>realname
|
||||
"email" value >>email
|
||||
|
||||
{ "new-password" "verify-password" }
|
||||
[ value empty? ] all? [
|
||||
same-password-twice
|
||||
"new-password" value >>password
|
||||
] unless
|
||||
|
||||
update-tuple
|
||||
|
||||
next f <standard-redirect>
|
||||
] >>submit ;
|
||||
|
||||
:: <delete-user-action> ( ctor next -- action )
|
||||
<action>
|
||||
{ { "username" [ ] } } >>post-params
|
||||
|
||||
[
|
||||
"username" get
|
||||
[ <user> select-tuple 1 >>deleted update-tuple ]
|
||||
[ logout-all-sessions ]
|
||||
bi
|
||||
|
||||
next f <standard-redirect>
|
||||
] >>submit ;
|
||||
|
||||
TUPLE: user-admin < dispatcher ;
|
||||
|
||||
:: <user-admin> ( -- responder )
|
||||
[let | ctor [ [ <user> ] ] |
|
||||
user-admin new-dispatcher
|
||||
<user-list-form> ctor <list-action> "" add-responder
|
||||
<new-user-form> ctor "$user-admin" <new-user-action> "new" add-responder
|
||||
<edit-user-form> ctor "$user-admin" <edit-user-action> "edit" add-responder
|
||||
ctor "$user-admin" <delete-user-action> "delete" add-responder
|
||||
<boilerplate>
|
||||
"admin" admin-template >>template
|
||||
<protected>
|
||||
] ;
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:style include="resource:extra/http/server/auth/admin/admin.css" />
|
||||
|
||||
<div class="navbar">
|
||||
<t:a t:href="$user-admin">List Users</t:a>
|
||||
| <t:a t:href="$user-admin/new">Add User</t:a>
|
||||
|
||||
<t:if t:code="http.server.auth.login:allow-edit-profile?">
|
||||
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
|
||||
</t:if>
|
||||
|
||||
<t:form t:action="$login/logout" t:flow="begin" class="inline">
|
||||
| <button type="submit" class="link-button link">Logout</button>
|
||||
</t:form>
|
||||
</div>
|
||||
|
||||
<h1><t:write-title /></h1>
|
||||
|
||||
<t:call-next-template />
|
||||
|
||||
</t:chloe>
|
||||
|
|
@ -0,0 +1,60 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:title>Edit User</t:title>
|
||||
|
||||
<t:form t:action="$user-admin/edit">
|
||||
|
||||
<t:edit t:component="username" />
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">User name:</th>
|
||||
<td><t:view t:component="username" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Real name:</th>
|
||||
<td><t:edit t:component="realname" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">New password:</th>
|
||||
<td><t:edit t:component="new-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Verify:</th>
|
||||
<td><t:edit t:component="verify-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">E-mail:</th>
|
||||
<td><t:edit t:component="email" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Profile:</th>
|
||||
<td><t:view t:component="profile" /></td>
|
||||
</tr>
|
||||
|
||||
</table>
|
||||
|
||||
<p>
|
||||
<button type="submit" class="link-button link">Update</button>
|
||||
|
||||
<t:if t:var="http.server.auth.login:password-mismatch?">
|
||||
<t:error>passwords do not match</t:error>
|
||||
</t:if>
|
||||
</p>
|
||||
|
||||
</t:form>
|
||||
|
||||
<t:form t:action="$user-admin/delete">
|
||||
<t:edit t:component="username" />
|
||||
|
||||
<button type="submit" class="link-button link">Delete</button>
|
||||
</t:form>
|
||||
</t:chloe>
|
||||
|
|
@ -0,0 +1,51 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:title>New User</t:title>
|
||||
|
||||
<t:form t:action="$user-admin/new">
|
||||
|
||||
<table>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">User name:</th>
|
||||
<td><t:edit t:component="username" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Real name:</th>
|
||||
<td><t:edit t:component="realname" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">New password:</th>
|
||||
<td><t:edit t:component="new-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">Verify:</th>
|
||||
<td><t:edit t:component="verify-password" /></td>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<th class="field-label">E-mail:</th>
|
||||
<td><t:edit t:component="email" /></td>
|
||||
</tr>
|
||||
|
||||
</table>
|
||||
|
||||
<p>
|
||||
<button type="submit" class="link-button link">Create</button>
|
||||
|
||||
<t:if t:var="http.server.auth.login:user-exists?">
|
||||
<t:error>username taken</t:error>
|
||||
</t:if>
|
||||
|
||||
<t:if t:var="http.server.auth.login:password-mismatch?">
|
||||
<t:error>passwords do not match</t:error>
|
||||
</t:if>
|
||||
</p>
|
||||
|
||||
</t:form>
|
||||
</t:chloe>
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:title>Users</t:title>
|
||||
|
||||
<t:summary t:component="list" />
|
||||
|
||||
</t:chloe>
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:a t:href="$user-admin/edit" t:query="username">
|
||||
<t:view t:component="username" />
|
||||
</t:a>
|
||||
|
||||
</t:chloe>
|
||||
|
|
@ -7,7 +7,6 @@ http.server.auth.providers ;
|
|||
IN: http.server.auth
|
||||
|
||||
SYMBOL: logged-in-user
|
||||
SYMBOL: user-profile-changed?
|
||||
|
||||
GENERIC: init-user-profile ( responder -- )
|
||||
|
||||
|
|
@ -19,16 +18,18 @@ M: dispatcher init-user-profile
|
|||
M: filter-responder init-user-profile
|
||||
responder>> init-user-profile ;
|
||||
|
||||
: uid ( -- string ) logged-in-user sget username>> ;
|
||||
: profile ( -- assoc ) logged-in-user get profile>> ;
|
||||
|
||||
: profile ( -- assoc ) logged-in-user sget profile>> ;
|
||||
: user-changed ( -- )
|
||||
logged-in-user get t >>changed? drop ;
|
||||
|
||||
: uget ( key -- value )
|
||||
profile at ;
|
||||
|
||||
: uset ( value key -- )
|
||||
profile set-at user-profile-changed? on ;
|
||||
profile set-at
|
||||
user-changed ;
|
||||
|
||||
: uchange ( quot key -- )
|
||||
profile swap change-at
|
||||
user-profile-changed? on ; inline
|
||||
user-changed ; inline
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
<t:title>Edit Profile</t:title>
|
||||
|
||||
<t:form t:action="edit-profile">
|
||||
<t:form t:action="$login/edit-profile">
|
||||
|
||||
<table>
|
||||
|
||||
|
|
|
|||
|
|
@ -35,9 +35,7 @@ TUPLE: user-saver user ;
|
|||
C: <user-saver> user-saver
|
||||
|
||||
M: user-saver dispose
|
||||
user-profile-changed? get [
|
||||
user>> users update-user
|
||||
] [ drop ] if ;
|
||||
user>> dup changed?>> [ users update-user ] [ drop ] if ;
|
||||
|
||||
: save-user-after ( user -- )
|
||||
<user-saver> add-always-destructor ;
|
||||
|
|
@ -59,7 +57,7 @@ M: user-saver dispose
|
|||
add-field ;
|
||||
|
||||
: successful-login ( user -- response )
|
||||
logged-in-user sset
|
||||
username>> set-uid
|
||||
"$login" end-flow ;
|
||||
|
||||
:: <login-action> ( -- action )
|
||||
|
|
@ -125,11 +123,11 @@ SYMBOL: user-exists?
|
|||
|
||||
same-password-twice
|
||||
|
||||
<user>
|
||||
"username" value >>username
|
||||
"username" value <user>
|
||||
"realname" value >>realname
|
||||
"new-password" value >>password
|
||||
"email" value >>email
|
||||
H{ } clone >>profile
|
||||
|
||||
users new-user [
|
||||
user-exists? on
|
||||
|
|
@ -160,7 +158,7 @@ SYMBOL: user-exists?
|
|||
[
|
||||
blank-values
|
||||
|
||||
logged-in-user sget
|
||||
logged-in-user get
|
||||
[ username>> "username" set-value ]
|
||||
[ realname>> "realname" set-value ]
|
||||
[ email>> "email" set-value ]
|
||||
|
|
@ -175,7 +173,7 @@ SYMBOL: user-exists?
|
|||
|
||||
form validate-form
|
||||
|
||||
logged-in-user sget
|
||||
logged-in-user get
|
||||
|
||||
{ "password" "new-password" "verify-password" }
|
||||
[ value empty? ] all? [
|
||||
|
|
@ -190,9 +188,9 @@ SYMBOL: user-exists?
|
|||
"realname" value >>realname
|
||||
"email" value >>email
|
||||
|
||||
drop
|
||||
t >>changed?
|
||||
|
||||
user-profile-changed? on
|
||||
drop
|
||||
|
||||
"$login" end-flow
|
||||
] >>submit
|
||||
|
|
@ -330,7 +328,7 @@ SYMBOL: lost-password-from
|
|||
: <logout-action> ( -- action )
|
||||
<action>
|
||||
[
|
||||
f logged-in-user sset
|
||||
f set-uid
|
||||
"$login/login" end-flow
|
||||
] >>submit ;
|
||||
|
||||
|
|
@ -345,8 +343,9 @@ C: <protected> protected
|
|||
"$login/login" f <standard-redirect> ;
|
||||
|
||||
M: protected call-responder* ( path responder -- response )
|
||||
logged-in-user sget dup [
|
||||
save-user-after
|
||||
uid dup [
|
||||
users get-user
|
||||
[ logged-in-user set ] [ save-user-after ] bi
|
||||
call-next-method
|
||||
] [
|
||||
3drop show-login-page
|
||||
|
|
|
|||
|
|
@ -6,17 +6,17 @@ namespaces accessors kernel ;
|
|||
<users-in-memory> "provider" set
|
||||
|
||||
[ t ] [
|
||||
<user>
|
||||
"slava" >>username
|
||||
"slava" <user>
|
||||
"foobar" >>password
|
||||
"slava@factorcode.org" >>email
|
||||
H{ } clone >>profile
|
||||
"provider" get new-user
|
||||
username>> "slava" =
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
<user>
|
||||
"slava" >>username
|
||||
"slava" <user>
|
||||
H{ } clone >>profile
|
||||
"provider" get new-user
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -6,22 +6,24 @@ io.files accessors kernel ;
|
|||
|
||||
users-in-db "provider" set
|
||||
|
||||
[ "auth-test.db" temp-file delete-file ] ignore-errors
|
||||
|
||||
"auth-test.db" temp-file sqlite-db [
|
||||
|
||||
init-users-table
|
||||
|
||||
[ t ] [
|
||||
<user>
|
||||
"slava" >>username
|
||||
"slava" <user>
|
||||
"foobar" >>password
|
||||
"slava@factorcode.org" >>email
|
||||
H{ } clone >>profile
|
||||
"provider" get new-user
|
||||
username>> "slava" =
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
<user>
|
||||
"slava" >>username
|
||||
"slava" <user>
|
||||
H{ } clone >>profile
|
||||
"provider" get new-user
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -7,31 +7,28 @@ IN: http.server.auth.providers.db
|
|||
|
||||
user "USERS"
|
||||
{
|
||||
{ "username" "USERNAME" { VARCHAR 256 } +assigned-id+ }
|
||||
{ "username" "USERNAME" { VARCHAR 256 } +user-assigned-id+ }
|
||||
{ "realname" "REALNAME" { VARCHAR 256 } }
|
||||
{ "password" "PASSWORD" { VARCHAR 256 } +not-null+ }
|
||||
{ "email" "EMAIL" { VARCHAR 256 } }
|
||||
{ "ticket" "TICKET" { VARCHAR 256 } }
|
||||
{ "profile" "PROFILE" FACTOR-BLOB }
|
||||
{ "deleted" "DELETED" INTEGER +not-null+ }
|
||||
} define-persistent
|
||||
|
||||
: init-users-table user ensure-table ;
|
||||
|
||||
SINGLETON: users-in-db
|
||||
|
||||
: find-user ( username -- user )
|
||||
<user>
|
||||
swap >>username
|
||||
select-tuple ;
|
||||
|
||||
M: users-in-db get-user
|
||||
drop
|
||||
find-user ;
|
||||
drop <user> select-tuple ;
|
||||
|
||||
M: users-in-db new-user
|
||||
drop
|
||||
[
|
||||
dup username>> find-user [
|
||||
user new
|
||||
over username>> >>username
|
||||
select-tuple [
|
||||
drop f
|
||||
] [
|
||||
dup insert-tuple
|
||||
|
|
|
|||
|
|
@ -4,9 +4,12 @@ USING: kernel accessors random math.parser locals
|
|||
sequences math crypto.sha2 ;
|
||||
IN: http.server.auth.providers
|
||||
|
||||
TUPLE: user username realname password email ticket profile ;
|
||||
TUPLE: user username realname password email ticket profile deleted changed? ;
|
||||
|
||||
: <user> user new H{ } clone >>profile ;
|
||||
: <user> ( username -- user )
|
||||
user new
|
||||
swap >>username
|
||||
0 >>deleted ;
|
||||
|
||||
GENERIC: get-user ( username provider -- user/f )
|
||||
|
||||
|
|
|
|||
|
|
@ -30,8 +30,6 @@ TUPLE: hidden < field ;
|
|||
|
||||
: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
|
||||
|
||||
M: hidden render-view* 2drop ;
|
||||
|
||||
! Component protocol
|
||||
SYMBOL: components
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,17 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: splitting kernel io sequences inspector accessors
|
||||
http.server.components ;
|
||||
IN: http.server.components.inspector
|
||||
|
||||
SINGLETON: inspector-renderer
|
||||
|
||||
M: inspector-renderer render-view*
|
||||
drop describe ;
|
||||
|
||||
TUPLE: inspector < component ;
|
||||
|
||||
M: inspector component-string drop ;
|
||||
|
||||
: <inspector> ( id -- component )
|
||||
inspector inspector-renderer new-component ;
|
||||
|
|
@ -51,7 +51,7 @@ IN: http.server.crud
|
|||
{ { "id" [ v-number ] } } >>post-params
|
||||
|
||||
[
|
||||
"id" get ctor call delete-tuple
|
||||
"id" get ctor call delete-tuples
|
||||
|
||||
next f <standard-redirect>
|
||||
] >>submit ;
|
||||
|
|
|
|||
|
|
@ -1,16 +1,12 @@
|
|||
IN: http.server.sessions.tests
|
||||
USING: tools.test http http.server.sessions
|
||||
http.server.sessions.storage http.server.sessions.storage.db
|
||||
http.server.actions http.server math namespaces kernel accessors
|
||||
prettyprint io.streams.string io.files splitting destructors
|
||||
sequences db db.sqlite continuations ;
|
||||
|
||||
: with-session
|
||||
[
|
||||
>r
|
||||
[ session-manager get swap save-session-after ]
|
||||
[ \ session set ] bi
|
||||
r> call
|
||||
>r [ save-session-after ] [ session set ] bi r> call
|
||||
] with-destructors ; inline
|
||||
|
||||
TUPLE: foo ;
|
||||
|
|
@ -31,18 +27,18 @@ M: foo call-responder*
|
|||
"id" get session-id-key set-query-param
|
||||
"/" >>path
|
||||
request set
|
||||
{ } session-manager get call-responder
|
||||
{ } sessions get call-responder
|
||||
[ write-response-body drop ] with-string-writer
|
||||
] with-destructors ;
|
||||
|
||||
: session-manager-mock-test
|
||||
: sessions-mock-test
|
||||
[
|
||||
<request>
|
||||
"GET" >>method
|
||||
"cookies" get >>cookies
|
||||
"/" >>path
|
||||
request set
|
||||
{ } session-manager get call-responder
|
||||
{ } sessions get call-responder
|
||||
[ write-response-body drop ] with-string-writer
|
||||
] with-destructors ;
|
||||
|
||||
|
|
@ -60,14 +56,15 @@ M: foo call-responder*
|
|||
init-sessions-table
|
||||
|
||||
[ ] [
|
||||
<foo> <session-manager>
|
||||
sessions-in-db >>sessions
|
||||
session-manager set
|
||||
<foo> <sessions>
|
||||
sessions set
|
||||
] unit-test
|
||||
|
||||
[
|
||||
empty-session
|
||||
123 >>id session set
|
||||
[ ] [
|
||||
empty-session
|
||||
123 >>id session set
|
||||
] unit-test
|
||||
|
||||
[ ] [ 3 "x" sset ] unit-test
|
||||
|
||||
|
|
@ -81,39 +78,38 @@ M: foo call-responder*
|
|||
] with-scope
|
||||
|
||||
[ t ] [
|
||||
session-manager get begin-session id>>
|
||||
session-manager get sessions>> get-session session?
|
||||
begin-session id>>
|
||||
get-session session?
|
||||
] unit-test
|
||||
|
||||
[ { 5 0 } ] [
|
||||
[
|
||||
session-manager get begin-session
|
||||
begin-session
|
||||
dup [ 5 "a" sset ] with-session
|
||||
dup [ "a" sget , ] with-session
|
||||
dup [ "x" sget , ] with-session
|
||||
id>> session-manager get sessions>> delete-session
|
||||
drop
|
||||
] { } make
|
||||
] unit-test
|
||||
|
||||
[ 0 ] [
|
||||
session-manager get begin-session id>>
|
||||
session-manager get sessions>> get-session [ "x" sget ] with-session
|
||||
begin-session id>>
|
||||
get-session [ "x" sget ] with-session
|
||||
] unit-test
|
||||
|
||||
[ { 5 0 } ] [
|
||||
[
|
||||
session-manager get begin-session id>>
|
||||
dup session-manager get sessions>> get-session [ 5 "a" sset ] with-session
|
||||
dup session-manager get sessions>> get-session [ "a" sget , ] with-session
|
||||
dup session-manager get sessions>> get-session [ "x" sget , ] with-session
|
||||
session-manager get sessions>> delete-session
|
||||
begin-session id>>
|
||||
dup get-session [ 5 "a" sset ] with-session
|
||||
dup get-session [ "a" sget , ] with-session
|
||||
dup get-session [ "x" sget , ] with-session
|
||||
drop
|
||||
] { } make
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
<foo> <session-manager>
|
||||
sessions-in-db >>sessions
|
||||
session-manager set
|
||||
<foo> <sessions>
|
||||
sessions set
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -121,7 +117,7 @@ M: foo call-responder*
|
|||
"GET" >>method
|
||||
"/" >>path
|
||||
request set
|
||||
{ "etc" } session-manager get call-responder response set
|
||||
{ "etc" } sessions get call-responder response set
|
||||
[ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
|
||||
response get
|
||||
] with-destructors
|
||||
|
|
@ -129,9 +125,9 @@ M: foo call-responder*
|
|||
|
||||
[ ] [ response get cookies>> "cookies" set ] unit-test
|
||||
|
||||
[ "2" ] [ session-manager-mock-test ] unit-test
|
||||
[ "3" ] [ session-manager-mock-test ] unit-test
|
||||
[ "4" ] [ session-manager-mock-test ] unit-test
|
||||
[ "2" ] [ sessions-mock-test ] unit-test
|
||||
[ "3" ] [ sessions-mock-test ] unit-test
|
||||
[ "4" ] [ sessions-mock-test ] unit-test
|
||||
|
||||
[
|
||||
[ ] [
|
||||
|
|
@ -142,8 +138,7 @@ M: foo call-responder*
|
|||
request set
|
||||
|
||||
[
|
||||
{ } <exiting-action> <session-manager>
|
||||
sessions-in-db >>sessions
|
||||
{ } <exiting-action> <sessions>
|
||||
call-responder
|
||||
] with-destructors response set
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,21 +1,40 @@
|
|||
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel math.parser namespaces random
|
||||
accessors quotations hashtables sequences continuations
|
||||
fry calendar combinators destructors
|
||||
http
|
||||
http.server
|
||||
http.server.sessions.storage
|
||||
http.server.sessions.storage.null
|
||||
html.elements ;
|
||||
USING: assocs kernel math.intervals math.parser namespaces
|
||||
random accessors quotations hashtables sequences continuations
|
||||
fry calendar combinators destructors alarms
|
||||
db db.tuples db.types
|
||||
http http.server html.elements ;
|
||||
IN: http.server.sessions
|
||||
|
||||
TUPLE: session id expires namespace changed? ;
|
||||
TUPLE: session id expires uid namespace changed? ;
|
||||
|
||||
: <session> ( id -- session )
|
||||
session new
|
||||
swap >>id ;
|
||||
|
||||
session "SESSIONS"
|
||||
{
|
||||
{ "id" "ID" +random-id+ system-random-generator }
|
||||
{ "expires" "EXPIRES" TIMESTAMP +not-null+ }
|
||||
{ "uid" "UID" { VARCHAR 255 } }
|
||||
{ "namespace" "NAMESPACE" FACTOR-BLOB }
|
||||
} define-persistent
|
||||
|
||||
: get-session ( id -- session )
|
||||
dup [ <session> select-tuple ] when ;
|
||||
|
||||
: init-sessions-table session ensure-table ;
|
||||
|
||||
: start-expiring-sessions ( db seq -- )
|
||||
'[
|
||||
, , [
|
||||
session new
|
||||
-1.0/0.0 now [a,b] >>expires
|
||||
delete-tuples
|
||||
] with-db
|
||||
] 5 minutes every drop ;
|
||||
|
||||
GENERIC: init-session* ( responder -- )
|
||||
|
||||
M: object init-session* drop ;
|
||||
|
|
@ -24,12 +43,11 @@ M: dispatcher init-session* default>> init-session* ;
|
|||
|
||||
M: filter-responder init-session* responder>> init-session* ;
|
||||
|
||||
TUPLE: session-manager < filter-responder sessions timeout domain ;
|
||||
TUPLE: sessions < filter-responder timeout domain ;
|
||||
|
||||
: <session-manager> ( responder -- responder' )
|
||||
session-manager new
|
||||
: <sessions> ( responder -- responder' )
|
||||
sessions new
|
||||
swap >>responder
|
||||
null-sessions >>sessions
|
||||
20 minutes >>timeout ;
|
||||
|
||||
: (session-changed) ( session -- )
|
||||
|
|
@ -50,11 +68,17 @@ TUPLE: session-manager < filter-responder sessions timeout domain ;
|
|||
[ namespace>> swap change-at ] keep
|
||||
(session-changed) ; inline
|
||||
|
||||
: init-session ( session managed -- )
|
||||
>r session r> '[ , init-session* ] with-variable ;
|
||||
: uid ( -- uid )
|
||||
session get uid>> ;
|
||||
|
||||
: set-uid ( uid -- )
|
||||
session get [ (>>uid) ] [ (session-changed) ] bi ;
|
||||
|
||||
: init-session ( session -- )
|
||||
session [ sessions get init-session* ] with-variable ;
|
||||
|
||||
: cutoff-time ( -- time )
|
||||
session-manager get timeout>> from-now timestamp>millis ;
|
||||
sessions get timeout>> from-now ;
|
||||
|
||||
: touch-session ( session -- )
|
||||
cutoff-time >>expires drop ;
|
||||
|
|
@ -64,57 +88,50 @@ TUPLE: session-manager < filter-responder sessions timeout domain ;
|
|||
H{ } clone >>namespace
|
||||
dup touch-session ;
|
||||
|
||||
: begin-session ( responder -- session )
|
||||
>r empty-session r>
|
||||
[ init-session ]
|
||||
[ sessions>> new-session ]
|
||||
[ drop ]
|
||||
2tri ;
|
||||
: begin-session ( -- session )
|
||||
empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
|
||||
|
||||
! Destructor
|
||||
TUPLE: session-saver manager session ;
|
||||
TUPLE: session-saver session ;
|
||||
|
||||
C: <session-saver> session-saver
|
||||
|
||||
M: session-saver dispose
|
||||
[ session>> ] [ manager>> sessions>> ] bi
|
||||
over changed?>> [
|
||||
[ drop touch-session ] [ update-session ] 2bi
|
||||
] [ 2drop ] if ;
|
||||
session>> dup changed?>> [
|
||||
[ touch-session ] [ update-tuple ] bi
|
||||
] [ drop ] if ;
|
||||
|
||||
: save-session-after ( manager session -- )
|
||||
: save-session-after ( session -- )
|
||||
<session-saver> add-always-destructor ;
|
||||
|
||||
: existing-session ( path manager session -- response )
|
||||
[ nip session set ]
|
||||
[ save-session-after ]
|
||||
[ drop responder>> ] 2tri
|
||||
call-responder ;
|
||||
: existing-session ( path session -- response )
|
||||
[ session set ] [ save-session-after ] bi
|
||||
sessions get responder>> call-responder ;
|
||||
|
||||
: session-id-key "factorsessid" ;
|
||||
|
||||
: cookie-session-id ( -- id/f )
|
||||
request get session-id-key get-cookie
|
||||
: cookie-session-id ( request -- id/f )
|
||||
session-id-key get-cookie
|
||||
dup [ value>> string>number ] when ;
|
||||
|
||||
: post-session-id ( -- id/f )
|
||||
session-id-key request get post-data>> at string>number ;
|
||||
: post-session-id ( request -- id/f )
|
||||
session-id-key swap post-data>> at string>number ;
|
||||
|
||||
: request-session-id ( -- id/f )
|
||||
request get method>> {
|
||||
request get dup method>> {
|
||||
{ "GET" [ cookie-session-id ] }
|
||||
{ "HEAD" [ cookie-session-id ] }
|
||||
{ "POST" [ post-session-id ] }
|
||||
} case ;
|
||||
|
||||
: request-session ( responder -- session/f )
|
||||
>r request-session-id r> sessions>> get-session ;
|
||||
: request-session ( -- session/f )
|
||||
request-session-id get-session ;
|
||||
|
||||
: <session-cookie> ( id -- cookie )
|
||||
session-id-key <cookie>
|
||||
"$session-manager" resolve-base-path >>path
|
||||
session-manager get timeout>> from-now >>expires
|
||||
session-manager get domain>> >>domain ;
|
||||
"$sessions" resolve-base-path >>path
|
||||
sessions get timeout>> from-now >>expires
|
||||
sessions get domain>> >>domain ;
|
||||
|
||||
: put-session-cookie ( response -- response' )
|
||||
session get id>> number>string <session-cookie> put-cookie ;
|
||||
|
|
@ -126,8 +143,11 @@ M: session-saver dispose
|
|||
session get id>> number>string =value
|
||||
input/> ;
|
||||
|
||||
M: session-manager call-responder* ( path responder -- response )
|
||||
M: sessions call-responder* ( path responder -- response )
|
||||
[ session-form-field ] add-form-hook
|
||||
dup session-manager set
|
||||
dup request-session [ dup begin-session ] unless*
|
||||
sessions set
|
||||
request-session [ begin-session ] unless*
|
||||
existing-session put-session-cookie ;
|
||||
|
||||
: logout-all-sessions ( uid -- )
|
||||
session new swap >>uid delete-tuples ;
|
||||
|
|
|
|||
|
|
@ -1,40 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs accessors kernel http.server.sessions.storage
|
||||
http.server.sessions http.server db db.tuples db.types math.parser
|
||||
math.intervals fry random calendar sequences alarms ;
|
||||
IN: http.server.sessions.storage.db
|
||||
|
||||
SINGLETON: sessions-in-db
|
||||
|
||||
session "SESSIONS"
|
||||
{
|
||||
! { "id" "ID" +random-id+ system-random-generator }
|
||||
{ "id" "ID" INTEGER +native-id+ }
|
||||
{ "expires" "EXPIRES" BIG-INTEGER +not-null+ }
|
||||
{ "namespace" "NAMESPACE" FACTOR-BLOB }
|
||||
} define-persistent
|
||||
|
||||
: init-sessions-table session ensure-table ;
|
||||
|
||||
M: sessions-in-db get-session ( id storage -- session/f )
|
||||
drop dup [ <session> select-tuple ] when ;
|
||||
|
||||
M: sessions-in-db update-session ( session storage -- )
|
||||
drop update-tuple ;
|
||||
|
||||
M: sessions-in-db delete-session ( id storage -- )
|
||||
drop <session> delete-tuple ;
|
||||
|
||||
M: sessions-in-db new-session ( session storage -- )
|
||||
drop insert-tuple ;
|
||||
|
||||
: expired-sessions ( -- session )
|
||||
f <session>
|
||||
USE: math now timestamp>millis [ 60 60 * 1000 * - ] keep [a,b] >>expires
|
||||
select-tuples ;
|
||||
|
||||
: start-expiring-sessions ( db seq -- )
|
||||
'[
|
||||
, , [ expired-sessions [ delete-tuple ] each ] with-db
|
||||
] 5 minutes every drop ;
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel http.server.sessions.storage ;
|
||||
IN: http.server.sessions.storage.null
|
||||
|
||||
SINGLETON: null-sessions
|
||||
|
||||
: null-sessions-error "No session storage installed" throw ;
|
||||
|
||||
M: null-sessions get-session null-sessions-error ;
|
||||
|
||||
M: null-sessions update-session null-sessions-error ;
|
||||
|
||||
M: null-sessions delete-session null-sessions-error ;
|
||||
|
||||
M: null-sessions new-session null-sessions-error ;
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: calendar ;
|
||||
IN: http.server.sessions.storage
|
||||
|
||||
GENERIC: get-session ( id storage -- session )
|
||||
|
||||
GENERIC: update-session ( session storage -- )
|
||||
|
||||
GENERIC: delete-session ( id storage -- )
|
||||
|
||||
GENERIC: new-session ( session storage -- )
|
||||
|
|
@ -120,9 +120,11 @@ $nl
|
|||
"Another limitation is that closure conversion does not descend into arrays, hashtables or other types of literals. For example, the following does not work:"
|
||||
{ $code
|
||||
":: bad-cond-usage ( a -- ... )"
|
||||
" { [ a 0 < ] [ ... ] }"
|
||||
" { [ a 0 > ] [ ... ] }"
|
||||
" { [ a 0 = ] [ ... ] } ;"
|
||||
" {"
|
||||
" { [ a 0 < ] [ ... ] }"
|
||||
" { [ a 0 > ] [ ... ] }"
|
||||
" { [ a 0 = ] [ ... ] }"
|
||||
" } cond ;"
|
||||
} ;
|
||||
|
||||
ARTICLE: "locals" "Local variables and lexical closures"
|
||||
|
|
|
|||
|
|
@ -81,16 +81,24 @@ C: <quote> quote
|
|||
UNION: special local quote local-word local-reader local-writer ;
|
||||
|
||||
: load-locals-quot ( args -- quot )
|
||||
dup [ local-reader? ] contains? [
|
||||
<reversed> [
|
||||
local-reader? [ 1array >r ] [ >r ] ?
|
||||
] map concat
|
||||
dup empty? [
|
||||
drop [ ]
|
||||
] [
|
||||
length [ load-locals ] curry >quotation
|
||||
dup [ local-reader? ] contains? [
|
||||
<reversed> [
|
||||
local-reader? [ 1array >r ] [ >r ] ?
|
||||
] map concat
|
||||
] [
|
||||
length [ load-locals ] curry >quotation
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: drop-locals-quot ( args -- quot )
|
||||
length [ drop-locals ] curry ;
|
||||
dup empty? [
|
||||
drop [ ]
|
||||
] [
|
||||
length [ drop-locals ] curry
|
||||
] if ;
|
||||
|
||||
: point-free-body ( quot args -- newquot )
|
||||
>r 1 head-slice* r> [ localize ] curry map concat ;
|
||||
|
|
|
|||
|
|
@ -80,10 +80,6 @@ M: integer (^)
|
|||
-rot (^mod)
|
||||
] if ; foldable
|
||||
|
||||
GENERIC: abs ( x -- y ) foldable
|
||||
|
||||
M: real abs dup 0 < [ neg ] when ;
|
||||
|
||||
GENERIC: absq ( x -- y ) foldable
|
||||
|
||||
M: real absq sq ;
|
||||
|
|
|
|||
|
|
@ -47,5 +47,6 @@ M: ratio - 2dup scale - -rot ratio+d / ;
|
|||
M: ratio * 2>fraction * >r * r> / ;
|
||||
M: ratio / scale / ;
|
||||
M: ratio /i scale /i ;
|
||||
M: ratio /f scale /f ;
|
||||
M: ratio mod 2dup >r >r /i r> r> rot * - ;
|
||||
M: ratio /mod [ /i ] 2keep mod ;
|
||||
|
|
|
|||
|
|
@ -73,7 +73,7 @@ SYMBOL: total
|
|||
! Part II: Topologically sorting specializers
|
||||
: maximal-element ( seq quot -- n elt )
|
||||
dupd [
|
||||
swapd [ call 0 < ] 2curry filter empty?
|
||||
swapd [ call +lt+ = ] 2curry filter empty?
|
||||
] 2curry find [ "Topological sort failed" throw ] unless* ;
|
||||
inline
|
||||
|
||||
|
|
@ -82,16 +82,16 @@ SYMBOL: total
|
|||
[ dupd maximal-element >r over delete-nth r> ] curry
|
||||
[ ] unfold nip ; inline
|
||||
|
||||
: classes< ( seq1 seq2 -- -1/0/1 )
|
||||
: classes< ( seq1 seq2 -- lt/eq/gt )
|
||||
[
|
||||
{
|
||||
{ [ 2dup eq? ] [ 0 ] }
|
||||
{ [ 2dup [ class< ] 2keep swap class< and ] [ 0 ] }
|
||||
{ [ 2dup class< ] [ -1 ] }
|
||||
{ [ 2dup swap class< ] [ 1 ] }
|
||||
[ 0 ]
|
||||
{ [ 2dup eq? ] [ +eq+ ] }
|
||||
{ [ 2dup [ class< ] 2keep swap class< and ] [ +eq+ ] }
|
||||
{ [ 2dup class< ] [ +lt+ ] }
|
||||
{ [ 2dup swap class< ] [ +gt+ ] }
|
||||
[ +eq+ ]
|
||||
} cond 2nip
|
||||
] 2map [ zero? not ] find nip 0 or ;
|
||||
] 2map [ zero? not ] find nip +eq+ or ;
|
||||
|
||||
: sort-methods ( alist -- alist' )
|
||||
[ [ first ] bi@ classes< ] topological-sort ;
|
||||
|
|
|
|||
|
|
@ -6,14 +6,14 @@ IN: multi-methods.tests
|
|||
{ 6 4 5 1 3 2 } [ <=> ] topological-sort
|
||||
] unit-test
|
||||
|
||||
[ -1 ] [
|
||||
[ +lt+ ] [
|
||||
{ fixnum array } { number sequence } classes<
|
||||
] unit-test
|
||||
|
||||
[ 0 ] [
|
||||
[ +eq+ ] [
|
||||
{ number sequence } { number sequence } classes<
|
||||
] unit-test
|
||||
|
||||
[ 1 ] [
|
||||
[ +gt+ ] [
|
||||
{ object object } { number sequence } classes<
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,18 +1,11 @@
|
|||
USING: arrays combinators.lib kernel math math.functions
|
||||
math.order math.vectors namespaces opengl opengl.gl sequences ui
|
||||
ui.gadgets ui.gestures ui.render ;
|
||||
ui.gadgets ui.gestures ui.render accessors ;
|
||||
IN: opengl.demo-support
|
||||
|
||||
: NEAR-PLANE 1.0 64.0 / ; inline
|
||||
: FAR-PLANE 4.0 ; inline
|
||||
: FOV 2.0 sqrt 1+ ; inline
|
||||
: MOUSE-MOTION-SCALE 0.5 ; inline
|
||||
: MOUSE-DISTANCE-SCALE 1.0 64.0 / ; inline
|
||||
: KEY-ROTATE-STEP 1.0 ; inline
|
||||
: KEY-DISTANCE-STEP 1.0 64.0 / ; inline
|
||||
: DIMS { 640 480 } ; inline
|
||||
|
||||
: FOV-RATIO ( -- fov ) DIMS dup first2 min v/n ;
|
||||
|
||||
SYMBOL: last-drag-loc
|
||||
|
||||
|
|
@ -20,7 +13,20 @@ TUPLE: demo-gadget yaw pitch distance ;
|
|||
|
||||
: <demo-gadget> ( yaw pitch distance -- gadget )
|
||||
demo-gadget construct-gadget
|
||||
[ { set-demo-gadget-yaw set-demo-gadget-pitch set-demo-gadget-distance } set-slots ] keep ;
|
||||
[ { (>>yaw) (>>pitch) (>>distance) } set-slots ] keep ;
|
||||
|
||||
GENERIC: far-plane ( gadget -- z )
|
||||
GENERIC: near-plane ( gadget -- z )
|
||||
GENERIC: distance-step ( gadget -- dz )
|
||||
|
||||
M: demo-gadget far-plane ( gadget -- z )
|
||||
drop 4.0 ;
|
||||
M: demo-gadget near-plane ( gadget -- z )
|
||||
drop 1.0 64.0 / ;
|
||||
M: demo-gadget distance-step ( gadget -- dz )
|
||||
drop 1.0 64.0 / ;
|
||||
|
||||
: fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ;
|
||||
|
||||
: yaw-demo-gadget ( yaw gadget -- )
|
||||
[ [ demo-gadget-yaw + ] keep set-demo-gadget-yaw ] keep relayout-1 ;
|
||||
|
|
@ -32,26 +38,31 @@ TUPLE: demo-gadget yaw pitch distance ;
|
|||
[ [ demo-gadget-distance + ] keep set-demo-gadget-distance ] keep relayout-1 ;
|
||||
|
||||
M: demo-gadget pref-dim* ( gadget -- dim )
|
||||
drop DIMS ;
|
||||
drop { 640 480 } ;
|
||||
|
||||
: -+ ( x -- -x x )
|
||||
dup neg swap ;
|
||||
|
||||
: demo-gadget-frustum ( -- -x x -y y near far )
|
||||
FOV-RATIO NEAR-PLANE FOV / v*n
|
||||
first2 [ -+ ] bi@ NEAR-PLANE FAR-PLANE ;
|
||||
: demo-gadget-frustum ( gadget -- -x x -y y near far )
|
||||
[ near-plane ] [ far-plane ] [ fov-ratio ] tri [
|
||||
nip swap FOV / v*n
|
||||
first2 [ -+ ] bi@
|
||||
] 3keep drop ;
|
||||
|
||||
: demo-gadget-set-matrices ( gadget -- )
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
demo-gadget-frustum glFrustum
|
||||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity
|
||||
[ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ]
|
||||
[ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ]
|
||||
[ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ]
|
||||
tri ;
|
||||
[
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
demo-gadget-frustum glFrustum
|
||||
] [
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity
|
||||
[ >r 0.0 0.0 r> distance>> neg glTranslatef ]
|
||||
[ pitch>> 1.0 0.0 0.0 glRotatef ]
|
||||
[ yaw>> 0.0 1.0 0.0 glRotatef ]
|
||||
tri
|
||||
] bi ;
|
||||
|
||||
: reset-last-drag-rel ( -- )
|
||||
{ 0 0 } last-drag-loc set-global ;
|
||||
|
|
@ -66,11 +77,11 @@ demo-gadget H{
|
|||
{ T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-gadget ] }
|
||||
{ T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-gadget ] }
|
||||
{ T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-gadget ] }
|
||||
{ T{ key-down f f "=" } [ KEY-DISTANCE-STEP neg swap zoom-demo-gadget ] }
|
||||
{ T{ key-down f f "-" } [ KEY-DISTANCE-STEP swap zoom-demo-gadget ] }
|
||||
{ T{ key-down f f "=" } [ dup distance-step neg swap zoom-demo-gadget ] }
|
||||
{ T{ key-down f f "-" } [ dup distance-step swap zoom-demo-gadget ] }
|
||||
|
||||
{ T{ button-down f f 1 } [ drop reset-last-drag-rel ] }
|
||||
{ T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] }
|
||||
{ T{ mouse-scroll } [ scroll-direction get second MOUSE-DISTANCE-SCALE * swap zoom-demo-gadget ] }
|
||||
{ T{ mouse-scroll } [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] }
|
||||
} set-gestures
|
||||
|
||||
|
|
|
|||
|
|
@ -1,15 +1,16 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: kernel tools.test peg peg.ebnf words math math.parser sequences ;
|
||||
USING: kernel tools.test peg peg.ebnf words math math.parser
|
||||
sequences accessors ;
|
||||
IN: peg.ebnf.tests
|
||||
|
||||
{ T{ ebnf-non-terminal f "abc" } } [
|
||||
"abc" 'non-terminal' parse parse-result-ast
|
||||
"abc" 'non-terminal' parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ T{ ebnf-terminal f "55" } } [
|
||||
"'55'" 'terminal' parse parse-result-ast
|
||||
"'55'" 'terminal' parse ast>>
|
||||
] unit-test
|
||||
|
||||
{
|
||||
|
|
@ -20,7 +21,7 @@ IN: peg.ebnf.tests
|
|||
}
|
||||
}
|
||||
} [
|
||||
"digit = '1' | '2'" 'rule' parse parse-result-ast
|
||||
"digit = '1' | '2'" 'rule' parse ast>>
|
||||
] unit-test
|
||||
|
||||
{
|
||||
|
|
@ -31,7 +32,7 @@ IN: peg.ebnf.tests
|
|||
}
|
||||
}
|
||||
} [
|
||||
"digit = '1' '2'" 'rule' parse parse-result-ast
|
||||
"digit = '1' '2'" 'rule' parse ast>>
|
||||
] unit-test
|
||||
|
||||
{
|
||||
|
|
@ -44,20 +45,22 @@ IN: peg.ebnf.tests
|
|||
}
|
||||
}
|
||||
} [
|
||||
"one two | three" 'choice' parse parse-result-ast
|
||||
"one two | three" 'choice' parse ast>>
|
||||
] unit-test
|
||||
|
||||
{
|
||||
T{ ebnf-sequence f
|
||||
V{
|
||||
T{ ebnf-non-terminal f "one" }
|
||||
T{ ebnf-choice f
|
||||
V{ T{ ebnf-non-terminal f "two" } T{ ebnf-non-terminal f "three" } }
|
||||
T{ ebnf-whitespace f
|
||||
T{ ebnf-choice f
|
||||
V{ T{ ebnf-non-terminal f "two" } T{ ebnf-non-terminal f "three" } }
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
} [
|
||||
"one (two | three)" 'choice' parse parse-result-ast
|
||||
"one {two | three}" 'choice' parse ast>>
|
||||
] unit-test
|
||||
|
||||
{
|
||||
|
|
@ -77,7 +80,7 @@ IN: peg.ebnf.tests
|
|||
}
|
||||
}
|
||||
} [
|
||||
"one ((two | three) four)*" 'choice' parse parse-result-ast
|
||||
"one ((two | three) four)*" 'choice' parse ast>>
|
||||
] unit-test
|
||||
|
||||
{
|
||||
|
|
@ -89,43 +92,43 @@ IN: peg.ebnf.tests
|
|||
}
|
||||
}
|
||||
} [
|
||||
"one ( two )? three" 'choice' parse parse-result-ast
|
||||
"one ( two )? three" 'choice' parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ "foo" } [
|
||||
"\"foo\"" 'identifier' parse parse-result-ast
|
||||
"\"foo\"" 'identifier' parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ "foo" } [
|
||||
"'foo'" 'identifier' parse parse-result-ast
|
||||
"'foo'" 'identifier' parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ "foo" } [
|
||||
"foo" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol
|
||||
"foo" 'non-terminal' parse ast>> ebnf-non-terminal-symbol
|
||||
] unit-test
|
||||
|
||||
{ "foo" } [
|
||||
"foo]" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol
|
||||
"foo]" 'non-terminal' parse ast>> ebnf-non-terminal-symbol
|
||||
] unit-test
|
||||
|
||||
{ V{ "a" "b" } } [
|
||||
"ab" [EBNF foo='a' 'b' EBNF] call parse-result-ast
|
||||
"ab" [EBNF foo='a' 'b' EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ 1 "b" } } [
|
||||
"ab" [EBNF foo=('a')[[ drop 1 ]] 'b' EBNF] call parse-result-ast
|
||||
"ab" [EBNF foo=('a')[[ drop 1 ]] 'b' EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ 1 2 } } [
|
||||
"ab" [EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF] call parse-result-ast
|
||||
"ab" [EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ CHAR: A } [
|
||||
"A" [EBNF foo=[A-Z] EBNF] call parse-result-ast
|
||||
"A" [EBNF foo=[A-Z] EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ CHAR: Z } [
|
||||
"Z" [EBNF foo=[A-Z] EBNF] call parse-result-ast
|
||||
"Z" [EBNF foo=[A-Z] EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
|
|
@ -133,7 +136,7 @@ IN: peg.ebnf.tests
|
|||
] unit-test
|
||||
|
||||
{ CHAR: 0 } [
|
||||
"0" [EBNF foo=[^A-Z] EBNF] call parse-result-ast
|
||||
"0" [EBNF foo=[^A-Z] EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
|
|
@ -145,31 +148,31 @@ IN: peg.ebnf.tests
|
|||
] unit-test
|
||||
|
||||
{ V{ "1" "+" "foo" } } [
|
||||
"1+1" [EBNF foo='1' '+' '1' [[ drop "foo" ]] EBNF] call parse-result-ast
|
||||
"1+1" [EBNF foo='1' '+' '1' [[ drop "foo" ]] EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ "foo" } [
|
||||
"1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] EBNF] call parse-result-ast
|
||||
"1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ "foo" } [
|
||||
"1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call parse-result-ast
|
||||
"1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ "bar" } [
|
||||
"1-1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call parse-result-ast
|
||||
"1-1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ 6 } [
|
||||
"4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ drop x y + ]] EBNF] call parse-result-ast
|
||||
"4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ drop x y + ]] EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ 6 } [
|
||||
"4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call parse-result-ast
|
||||
"4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ 10 } [
|
||||
{ 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
|
||||
{ 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
|
|
@ -177,7 +180,7 @@ IN: peg.ebnf.tests
|
|||
] unit-test
|
||||
|
||||
{ 3 } [
|
||||
{ 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
|
||||
{ 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
|
|
@ -185,44 +188,44 @@ IN: peg.ebnf.tests
|
|||
] unit-test
|
||||
|
||||
{ V{ "a" " " "b" } } [
|
||||
"a b" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast
|
||||
"a b" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ "a" "\t" "b" } } [
|
||||
"a\tb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast
|
||||
"a\tb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ "a" "\n" "b" } } [
|
||||
"a\nb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast
|
||||
"a\nb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ "a" f "b" } } [
|
||||
"ab" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
|
||||
"ab" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ "a" " " "b" } } [
|
||||
"a b" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
|
||||
"a b" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
|
||||
{ V{ "a" "\t" "b" } } [
|
||||
"a\tb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
|
||||
"a\tb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ "a" "\n" "b" } } [
|
||||
"a\nb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
|
||||
"a\nb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ "a" "b" } } [
|
||||
"ab" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast
|
||||
"ab" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ "a" "b" } } [
|
||||
"a\tb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast
|
||||
"a\tb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ "a" "b" } } [
|
||||
"a\nb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast
|
||||
"a\nb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
|
|
@ -232,19 +235,19 @@ IN: peg.ebnf.tests
|
|||
{ V{ V{ 49 } "+" V{ 49 } } } [
|
||||
#! Test direct left recursion.
|
||||
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
|
||||
"1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call parse-result-ast
|
||||
"1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [
|
||||
#! Test direct left recursion.
|
||||
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
|
||||
"1+1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call parse-result-ast
|
||||
"1+1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [
|
||||
#! Test indirect left recursion.
|
||||
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
|
||||
"1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call parse-result-ast
|
||||
"1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
|
|
@ -277,23 +280,88 @@ main = Primary
|
|||
;EBNF
|
||||
|
||||
{ "this" } [
|
||||
"this" primary parse-result-ast
|
||||
"this" primary ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ "this" "." "x" } } [
|
||||
"this.x" primary parse-result-ast
|
||||
"this.x" primary ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ V{ "this" "." "x" } "." "y" } } [
|
||||
"this.x.y" primary parse-result-ast
|
||||
"this.x.y" primary ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ V{ "this" "." "x" } "." "m" "(" ")" } } [
|
||||
"this.x.m()" primary parse-result-ast
|
||||
"this.x.m()" primary ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ V{ V{ "x" "[" "i" "]" } "[" "j" "]" } "." "y" } } [
|
||||
"x[i][j].y" primary parse-result-ast
|
||||
"x[i][j].y" primary ast>>
|
||||
] unit-test
|
||||
|
||||
'ebnf' compile must-infer
|
||||
|
||||
{ V{ V{ "a" "b" } "c" } } [
|
||||
"abc" [EBNF a="a" "b" foo=(a "c") EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ V{ "a" "b" } "c" } } [
|
||||
"abc" [EBNF a="a" "b" foo={a "c"} EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ V{ "a" "b" } "c" } } [
|
||||
"abc" [EBNF a="a" "b" foo=a "c" EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
"a bc" [EBNF a="a" "b" foo=(a "c") EBNF] call
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
"a bc" [EBNF a="a" "b" foo=a "c" EBNF] call
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
"a bc" [EBNF a="a" "b" foo={a "c"} EBNF] call
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
"ab c" [EBNF a="a" "b" foo=a "c" EBNF] call
|
||||
] unit-test
|
||||
|
||||
{ V{ V{ "a" "b" } "c" } } [
|
||||
"ab c" [EBNF a="a" "b" foo={a "c"} EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
"ab c" [EBNF a="a" "b" foo=(a "c") EBNF] call
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
"a b c" [EBNF a="a" "b" foo=a "c" EBNF] call
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
"a b c" [EBNF a="a" "b" foo=(a "c") EBNF] call
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
"a b c" [EBNF a="a" "b" foo={a "c"} EBNF] call
|
||||
] unit-test
|
||||
|
||||
{ V{ V{ V{ "a" "b" } "c" } V{ V{ "a" "b" } "c" } } } [
|
||||
"ab cab c" [EBNF a="a" "b" foo={a "c"}* EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ } } [
|
||||
"ab cab c" [EBNF a="a" "b" foo=(a "c")* EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ V{ V{ "a" "b" } "c" } V{ V{ "a" "b" } "c" } } } [
|
||||
"ab c ab c" [EBNF a="a" "b" foo={a "c"}* EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ } } [
|
||||
"ab c ab c" [EBNF a="a" "b" foo=(a "c")* EBNF] call ast>>
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@ TUPLE: ebnf-sequence elements ;
|
|||
TUPLE: ebnf-repeat0 group ;
|
||||
TUPLE: ebnf-repeat1 group ;
|
||||
TUPLE: ebnf-optional group ;
|
||||
TUPLE: ebnf-whitespace group ;
|
||||
TUPLE: ebnf-rule symbol elements ;
|
||||
TUPLE: ebnf-action parser code ;
|
||||
TUPLE: ebnf-var parser name ;
|
||||
|
|
@ -34,6 +35,7 @@ C: <ebnf-sequence> ebnf-sequence
|
|||
C: <ebnf-repeat0> ebnf-repeat0
|
||||
C: <ebnf-repeat1> ebnf-repeat1
|
||||
C: <ebnf-optional> ebnf-optional
|
||||
C: <ebnf-whitespace> ebnf-whitespace
|
||||
C: <ebnf-rule> ebnf-rule
|
||||
C: <ebnf-action> ebnf-action
|
||||
C: <ebnf-var> ebnf-var
|
||||
|
|
@ -84,6 +86,7 @@ C: <ebnf> ebnf
|
|||
[ dup CHAR: + = ]
|
||||
[ dup CHAR: ? = ]
|
||||
[ dup CHAR: : = ]
|
||||
[ dup CHAR: ~ = ]
|
||||
} || not nip
|
||||
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
|
||||
|
||||
|
|
@ -134,9 +137,15 @@ DEFER: 'choice'
|
|||
#! Parse a group of choices, with a suffix indicating
|
||||
#! the type of group (repeat0, repeat1, etc) and
|
||||
#! an quot that is the action that produces the AST.
|
||||
"(" [ 'choice' sp ] delay ")" syntax-pack
|
||||
swap 2seq
|
||||
[ first ] rot compose action ;
|
||||
2dup
|
||||
[
|
||||
"(" [ 'choice' sp ] delay ")" syntax-pack
|
||||
swap 2seq
|
||||
[ first ] rot compose action ,
|
||||
"{" [ 'choice' sp ] delay "}" syntax-pack
|
||||
swap 2seq
|
||||
[ first <ebnf-whitespace> ] rot compose action ,
|
||||
] choice* ;
|
||||
|
||||
: 'group' ( -- parser )
|
||||
#! A grouping with no suffix. Used for precedence.
|
||||
|
|
@ -238,9 +247,15 @@ GENERIC: (transform) ( ast -- parser )
|
|||
|
||||
SYMBOL: parser
|
||||
SYMBOL: main
|
||||
SYMBOL: ignore-ws
|
||||
|
||||
: transform ( ast -- object )
|
||||
H{ } clone dup dup [ parser set swap (transform) main set ] bind ;
|
||||
H{ } clone dup dup [
|
||||
f ignore-ws set
|
||||
parser set
|
||||
swap (transform)
|
||||
main set
|
||||
] bind ;
|
||||
|
||||
M: ebnf (transform) ( ast -- parser )
|
||||
rules>> [ (transform) ] map peek ;
|
||||
|
|
@ -252,7 +267,13 @@ M: ebnf-rule (transform) ( ast -- parser )
|
|||
] keep ;
|
||||
|
||||
M: ebnf-sequence (transform) ( ast -- parser )
|
||||
elements>> [ (transform) ] map seq [ dup length 1 = [ first ] when ] action ;
|
||||
#! If ignore-ws is set then each element of the sequence
|
||||
#! ignores leading whitespace. This is not inherited by
|
||||
#! subelements of the sequence.
|
||||
elements>> [
|
||||
f ignore-ws [ (transform) ] with-variable
|
||||
ignore-ws get [ sp ] when
|
||||
] map seq [ dup length 1 = [ first ] when ] action ;
|
||||
|
||||
M: ebnf-choice (transform) ( ast -- parser )
|
||||
options>> [ (transform) ] map choice ;
|
||||
|
|
@ -282,6 +303,9 @@ M: ebnf-repeat1 (transform) ( ast -- parser )
|
|||
M: ebnf-optional (transform) ( ast -- parser )
|
||||
transform-group optional ;
|
||||
|
||||
M: ebnf-whitespace (transform) ( ast -- parser )
|
||||
t ignore-ws [ transform-group ] with-variable ;
|
||||
|
||||
GENERIC: build-locals ( code ast -- code )
|
||||
|
||||
M: ebnf-sequence build-locals ( code ast -- code )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays strings math.parser sequences
|
||||
peg peg.ebnf peg.parsers memoize math ;
|
||||
peg peg.ebnf peg.parsers memoize math accessors ;
|
||||
IN: peg.expr
|
||||
|
||||
EBNF: expr
|
||||
|
|
@ -20,5 +20,5 @@ exp = exp "+" fac => [[ first3 nip + ]]
|
|||
;EBNF
|
||||
|
||||
: eval-expr ( string -- number )
|
||||
expr parse-result-ast ;
|
||||
expr ast>> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words math ;
|
||||
USING: kernel tools.test strings namespaces arrays sequences
|
||||
peg peg.private accessors words math accessors ;
|
||||
IN: peg.tests
|
||||
|
||||
{ f } [
|
||||
|
|
@ -10,7 +11,7 @@ IN: peg.tests
|
|||
|
||||
{ "begin" "end" } [
|
||||
"beginend" "begin" token parse
|
||||
{ parse-result-ast parse-result-remaining } get-slots
|
||||
{ ast>> remaining>> } get-slots
|
||||
>string
|
||||
] unit-test
|
||||
|
||||
|
|
@ -23,11 +24,11 @@ IN: peg.tests
|
|||
] unit-test
|
||||
|
||||
{ CHAR: a } [
|
||||
"abcd" CHAR: a CHAR: z range parse parse-result-ast
|
||||
"abcd" CHAR: a CHAR: z range parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ CHAR: z } [
|
||||
"zbcd" CHAR: a CHAR: z range parse parse-result-ast
|
||||
"zbcd" CHAR: a CHAR: z range parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
|
|
@ -35,15 +36,15 @@ IN: peg.tests
|
|||
] unit-test
|
||||
|
||||
{ V{ "g" "o" } } [
|
||||
"good" "g" token "o" token 2array seq parse parse-result-ast
|
||||
"good" "g" token "o" token 2array seq parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ "a" } [
|
||||
"abcd" "a" token "b" token 2array choice parse parse-result-ast
|
||||
"abcd" "a" token "b" token 2array choice parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ "b" } [
|
||||
"bbcd" "a" token "b" token 2array choice parse parse-result-ast
|
||||
"bbcd" "a" token "b" token 2array choice parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
|
|
@ -55,15 +56,15 @@ IN: peg.tests
|
|||
] unit-test
|
||||
|
||||
{ 0 } [
|
||||
"" "a" token repeat0 parse parse-result-ast length
|
||||
"" "a" token repeat0 parse ast>> length
|
||||
] unit-test
|
||||
|
||||
{ 0 } [
|
||||
"b" "a" token repeat0 parse parse-result-ast length
|
||||
"b" "a" token repeat0 parse ast>> length
|
||||
] unit-test
|
||||
|
||||
{ V{ "a" "a" "a" } } [
|
||||
"aaab" "a" token repeat0 parse parse-result-ast
|
||||
"aaab" "a" token repeat0 parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
|
|
@ -75,15 +76,15 @@ IN: peg.tests
|
|||
] unit-test
|
||||
|
||||
{ V{ "a" "a" "a" } } [
|
||||
"aaab" "a" token repeat1 parse parse-result-ast
|
||||
"aaab" "a" token repeat1 parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ "a" "b" } } [
|
||||
"ab" "a" token optional "b" token 2array seq parse parse-result-ast
|
||||
"ab" "a" token optional "b" token 2array seq parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ f "b" } } [
|
||||
"b" "a" token optional "b" token 2array seq parse parse-result-ast
|
||||
"b" "a" token optional "b" token 2array seq parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
|
|
@ -91,7 +92,7 @@ IN: peg.tests
|
|||
] unit-test
|
||||
|
||||
{ V{ CHAR: a CHAR: b } } [
|
||||
"ab" "a" token ensure CHAR: a CHAR: z range dup 3array seq parse parse-result-ast
|
||||
"ab" "a" token ensure CHAR: a CHAR: z range dup 3array seq parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
|
|
@ -123,11 +124,11 @@ IN: peg.tests
|
|||
] unit-test
|
||||
|
||||
{ 1 } [
|
||||
"a" "a" token [ drop 1 ] action parse parse-result-ast
|
||||
"a" "a" token [ drop 1 ] action parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ 1 1 } } [
|
||||
"aa" "a" token [ drop 1 ] action dup 2array seq parse parse-result-ast
|
||||
"aa" "a" token [ drop 1 ] action dup 2array seq parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
|
|
@ -139,19 +140,19 @@ IN: peg.tests
|
|||
] unit-test
|
||||
|
||||
{ CHAR: a } [
|
||||
"a" [ CHAR: a = ] satisfy parse parse-result-ast
|
||||
"a" [ CHAR: a = ] satisfy parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ "a" } [
|
||||
" a" "a" token sp parse parse-result-ast
|
||||
" a" "a" token sp parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ "a" } [
|
||||
"a" "a" token sp parse parse-result-ast
|
||||
"a" "a" token sp parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ V{ "a" } } [
|
||||
"[a]" "[" token hide "a" token "]" token hide 3array seq parse parse-result-ast
|
||||
"[a]" "[" token hide "a" token "]" token hide 3array seq parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
|
|
@ -164,8 +165,8 @@ IN: peg.tests
|
|||
[ "1" token , "-" token , "1" token , ] seq* ,
|
||||
[ "1" token , "+" token , "1" token , ] seq* ,
|
||||
] choice*
|
||||
"1-1" over parse parse-result-ast swap
|
||||
"1+1" swap parse parse-result-ast
|
||||
"1-1" over parse ast>> swap
|
||||
"1+1" swap parse ast>>
|
||||
] unit-test
|
||||
|
||||
: expr ( -- parser )
|
||||
|
|
@ -174,7 +175,7 @@ IN: peg.tests
|
|||
[ expr ] delay "+" token "1" token 3seq "1" token 2choice ;
|
||||
|
||||
{ V{ V{ "1" "+" "1" } "+" "1" } } [
|
||||
"1+1+1" expr parse parse-result-ast
|
||||
"1+1+1" expr parse ast>>
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
|
|
@ -189,6 +190,6 @@ IN: peg.tests
|
|||
] unit-test
|
||||
|
||||
{ CHAR: B } [
|
||||
"B" [ drop t ] satisfy [ 66 >= ] semantic parse parse-result-ast
|
||||
"B" [ drop t ] satisfy [ 66 >= ] semantic parse ast>>
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,43 +1,44 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: kernel tools.test peg peg.ebnf peg.pl0 multiline sequences ;
|
||||
USING: kernel tools.test peg peg.ebnf peg.pl0
|
||||
multiline sequences accessors ;
|
||||
IN: peg.pl0.tests
|
||||
|
||||
{ t } [
|
||||
"CONST foo = 1;" "block" \ pl0 rule parse parse-result-remaining empty?
|
||||
"CONST foo = 1;" "block" \ pl0 rule parse remaining>> empty?
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
"VAR foo;" "block" \ pl0 rule parse parse-result-remaining empty?
|
||||
"VAR foo;" "block" \ pl0 rule parse remaining>> empty?
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
"VAR foo,bar , baz;" "block" \ pl0 rule parse parse-result-remaining empty?
|
||||
"VAR foo,bar , baz;" "block" \ pl0 rule parse remaining>> empty?
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
"foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
|
||||
"foo := 5" "statement" \ pl0 rule parse remaining>> empty?
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
"BEGIN foo := 5 END" "statement" \ pl0 rule parse parse-result-remaining empty?
|
||||
"BEGIN foo := 5 END" "statement" \ pl0 rule parse remaining>> empty?
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
"IF 1=1 THEN foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
|
||||
"IF 1=1 THEN foo := 5" "statement" \ pl0 rule parse remaining>> empty?
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
"WHILE 1=1 DO foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
|
||||
"WHILE 1=1 DO foo := 5" "statement" \ pl0 rule parse remaining>> empty?
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
"WHILE ODD 1 DO foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
|
||||
"WHILE ODD 1 DO foo := 5" "statement" \ pl0 rule parse remaining>> empty?
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
"PROCEDURE square; BEGIN squ:=x*x END" "block" \ pl0 rule parse parse-result-remaining empty?
|
||||
"PROCEDURE square; BEGIN squ:=x*x END" "block" \ pl0 rule parse remaining>> empty?
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
|
|
@ -57,7 +58,7 @@ BEGIN
|
|||
x := x + 1;
|
||||
END
|
||||
END.
|
||||
"> pl0 parse-result-remaining empty?
|
||||
"> pl0 remaining>> empty?
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
|
|
@ -123,5 +124,5 @@ BEGIN
|
|||
y := 36;
|
||||
CALL gcd;
|
||||
END.
|
||||
"> pl0 parse-result-remaining empty?
|
||||
"> pl0 remaining>> empty?
|
||||
] unit-test
|
||||
|
|
@ -7,52 +7,22 @@ IN: peg.pl0
|
|||
#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
|
||||
|
||||
EBNF: pl0
|
||||
_ = (" " | "\t" | "\n")* => [[ drop ignore ]]
|
||||
|
||||
BEGIN = "BEGIN" _
|
||||
CALL = "CALL" _
|
||||
CONST = "CONST" _
|
||||
DO = "DO" _
|
||||
END = "END" _
|
||||
IF = "IF" _
|
||||
THEN = "THEN" _
|
||||
ODD = "ODD" _
|
||||
PROCEDURE = "PROCEDURE" _
|
||||
VAR = "VAR" _
|
||||
WHILE = "WHILE" _
|
||||
EQ = "=" _
|
||||
LTEQ = "<=" _
|
||||
LT = "<" _
|
||||
GT = ">" _
|
||||
GTEQ = ">=" _
|
||||
NEQ = "#" _
|
||||
COMMA = "," _
|
||||
SEMICOLON = ";" _
|
||||
ASSIGN = ":=" _
|
||||
|
||||
ADD = "+" _
|
||||
SUBTRACT = "-" _
|
||||
MULTIPLY = "*" _
|
||||
DIVIDE = "/" _
|
||||
|
||||
LPAREN = "(" _
|
||||
RPAREN = ")" _
|
||||
|
||||
block = ( CONST ident EQ number ( COMMA ident EQ number )* SEMICOLON )?
|
||||
( VAR ident ( COMMA ident )* SEMICOLON )?
|
||||
( PROCEDURE ident SEMICOLON ( block SEMICOLON )? )* statement
|
||||
statement = ( ident ASSIGN expression
|
||||
| CALL ident
|
||||
| BEGIN statement ( SEMICOLON statement )* END
|
||||
| IF condition THEN statement
|
||||
| WHILE condition DO statement )?
|
||||
condition = ODD expression
|
||||
| expression (EQ | NEQ | LTEQ | LT | GTEQ | GT) expression
|
||||
expression = (ADD | SUBTRACT)? term ( (ADD | SUBTRACT) term )* _
|
||||
term = factor ( (MULTIPLY | DIVIDE) factor )*
|
||||
factor = ident | number | LPAREN expression RPAREN
|
||||
ident = (([a-zA-Z])+) _ => [[ >string ]]
|
||||
block = { "CONST" ident "=" number { "," ident "=" number }* ";" }?
|
||||
{ "VAR" ident { "," ident }* ";" }?
|
||||
{ "PROCEDURE" ident ";" { block ";" }? }* statement
|
||||
statement = { ident ":=" expression
|
||||
| "CALL" ident
|
||||
| "BEGIN" statement { ";" statement }* "END"
|
||||
| "IF" condition "THEN" statement
|
||||
| "WHILE" condition "DO" statement }?
|
||||
condition = { "ODD" expression }
|
||||
| { expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression }
|
||||
expression = {"+" | "-"}? term { {"+" | "-"} term }*
|
||||
term = factor { {"*" | "/"} factor }*
|
||||
factor = ident | number | "(" expression ")"
|
||||
ident = (([a-zA-Z])+) => [[ >string ]]
|
||||
digit = ([0-9]) => [[ digit> ]]
|
||||
number = ((digit)+) _ => [[ 10 digits>integer ]]
|
||||
program = _ block "."
|
||||
number = (digit)+ => [[ 10 digits>integer ]]
|
||||
program = { block "." }
|
||||
;EBNF
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ C: <node> node
|
|||
|
||||
node "node"
|
||||
{
|
||||
{ "id" "id" +native-id+ +autoincrement+ }
|
||||
{ "id" "id" +db-assigned-id+ +autoincrement+ }
|
||||
{ "content" "content" TEXT }
|
||||
} define-persistent
|
||||
|
||||
|
|
|
|||
|
|
@ -66,9 +66,9 @@ MACRO: firstn ( n -- )
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: higher ( a b quot -- c ) [ compare 0 > ] curry most ; inline
|
||||
: higher ( a b quot -- c ) [ compare +gt+ eq? ] curry most ; inline
|
||||
|
||||
: lower ( a b quot -- c ) [ compare 0 < ] curry most ; inline
|
||||
: lower ( a b quot -- c ) [ compare +lt+ eq? ] curry most ; inline
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,284 @@
|
|||
USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers
|
||||
opengl multiline ui.gadgets accessors sequences ui.render ui math
|
||||
arrays arrays.lib combinators ;
|
||||
IN: spheres
|
||||
|
||||
STRING: plane-vertex-shader
|
||||
varying vec3 object_position;
|
||||
void
|
||||
main()
|
||||
{
|
||||
object_position = gl_Vertex.xyz;
|
||||
gl_Position = ftransform();
|
||||
}
|
||||
;
|
||||
|
||||
STRING: plane-fragment-shader
|
||||
varying vec3 object_position;
|
||||
void
|
||||
main()
|
||||
{
|
||||
float distance_factor = (gl_FragCoord.z * 0.5 + 0.5);
|
||||
distance_factor = pow(distance_factor, 500.0)*0.5;
|
||||
|
||||
gl_FragColor = fract((floor(0.125*object_position.x)+floor(0.125*object_position.z)) * 0.5) == 0.0
|
||||
? vec4(1.0, 1.0 - distance_factor, 1.0 - distance_factor, 1.0)
|
||||
: vec4(1.0, distance_factor, distance_factor, 1.0);
|
||||
}
|
||||
;
|
||||
|
||||
STRING: sphere-vertex-shader
|
||||
attribute vec3 center;
|
||||
attribute float radius;
|
||||
attribute vec4 surface_color;
|
||||
varying float vradius;
|
||||
varying vec3 sphere_position;
|
||||
varying vec4 world_position, vcolor;
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
world_position = gl_ModelViewMatrix * vec4(center, 1);
|
||||
sphere_position = gl_Vertex.xyz;
|
||||
|
||||
gl_Position = gl_ProjectionMatrix * (world_position + vec4(sphere_position * radius, 0));
|
||||
|
||||
vcolor = surface_color;
|
||||
vradius = radius;
|
||||
}
|
||||
;
|
||||
|
||||
STRING: sphere-solid-color-fragment-shader
|
||||
uniform vec3 light_position;
|
||||
varying vec4 vcolor;
|
||||
|
||||
const vec4 ambient = vec4(0.25, 0.2, 0.25, 1.0);
|
||||
const vec4 diffuse = vec4(0.75, 0.8, 0.75, 1.0);
|
||||
|
||||
vec4
|
||||
sphere_color(vec3 point, vec3 normal)
|
||||
{
|
||||
vec3 transformed_light_position = (gl_ModelViewMatrix * vec4(light_position, 1)).xyz;
|
||||
vec3 direction = normalize(transformed_light_position - point);
|
||||
float d = max(0.0, dot(normal, direction));
|
||||
|
||||
return ambient * vcolor + diffuse * vec4(d * vcolor.rgb, vcolor.a);
|
||||
}
|
||||
;
|
||||
|
||||
STRING: sphere-texture-fragment-shader
|
||||
uniform samplerCube surface_texture;
|
||||
|
||||
vec4
|
||||
sphere_color(vec3 point, vec3 normal)
|
||||
{
|
||||
vec3 reflect = reflect(normalize(point), normal);
|
||||
return textureCube(surface_texture, reflect * gl_NormalMatrix);
|
||||
}
|
||||
;
|
||||
|
||||
STRING: sphere-main-fragment-shader
|
||||
varying float vradius;
|
||||
varying vec3 sphere_position;
|
||||
varying vec4 world_position;
|
||||
|
||||
vec4 sphere_color(vec3 point, vec3 normal);
|
||||
|
||||
void
|
||||
main()
|
||||
{
|
||||
float radius = length(sphere_position);
|
||||
if(radius > 1.0) discard;
|
||||
|
||||
vec3 surface = sphere_position + vec3(0.0, 0.0, sqrt(1.0 - radius*radius));
|
||||
vec4 world_surface = world_position + vec4(surface * vradius, 0);
|
||||
vec4 transformed_surface = gl_ProjectionMatrix * world_surface;
|
||||
|
||||
gl_FragDepth = (transformed_surface.z/transformed_surface.w + 1.0) * 0.5;
|
||||
gl_FragColor = sphere_color(world_surface.xyz, surface);
|
||||
}
|
||||
;
|
||||
|
||||
TUPLE: spheres-gadget
|
||||
plane-program solid-sphere-program texture-sphere-program
|
||||
reflection-framebuffer reflection-depthbuffer
|
||||
reflection-texture ;
|
||||
|
||||
: <spheres-gadget> ( -- gadget )
|
||||
20.0 10.0 20.0 <demo-gadget>
|
||||
{ set-delegate } spheres-gadget construct ;
|
||||
|
||||
M: spheres-gadget near-plane ( gadget -- z )
|
||||
drop 1.0 ;
|
||||
M: spheres-gadget far-plane ( gadget -- z )
|
||||
drop 512.0 ;
|
||||
M: spheres-gadget distance-step ( gadget -- dz )
|
||||
drop 0.5 ;
|
||||
|
||||
: (reflection-dim) ( -- w h )
|
||||
512 512 ;
|
||||
|
||||
: (make-reflection-texture) ( -- texture )
|
||||
gen-texture [
|
||||
GL_TEXTURE_CUBE_MAP swap glBindTexture
|
||||
GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
|
||||
GL_TEXTURE_CUBE_MAP GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
|
||||
GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
|
||||
GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri
|
||||
GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R GL_CLAMP glTexParameteri
|
||||
GL_TEXTURE_CUBE_MAP_POSITIVE_X
|
||||
GL_TEXTURE_CUBE_MAP_POSITIVE_Y
|
||||
GL_TEXTURE_CUBE_MAP_POSITIVE_Z
|
||||
GL_TEXTURE_CUBE_MAP_NEGATIVE_X
|
||||
GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
|
||||
GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 6 narray
|
||||
[ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ]
|
||||
each
|
||||
] keep ;
|
||||
|
||||
: (make-reflection-depthbuffer) ( -- depthbuffer )
|
||||
gen-renderbuffer [
|
||||
GL_RENDERBUFFER_EXT swap glBindRenderbufferEXT
|
||||
GL_RENDERBUFFER_EXT GL_DEPTH_COMPONENT32 (reflection-dim) glRenderbufferStorageEXT
|
||||
] keep ;
|
||||
|
||||
: (make-reflection-framebuffer) ( depthbuffer -- framebuffer )
|
||||
gen-framebuffer dup [
|
||||
swap >r
|
||||
GL_FRAMEBUFFER_EXT GL_DEPTH_ATTACHMENT_EXT GL_RENDERBUFFER_EXT r>
|
||||
glFramebufferRenderbufferEXT
|
||||
] with-framebuffer ;
|
||||
|
||||
: (plane-program) ( -- program )
|
||||
plane-vertex-shader plane-fragment-shader <simple-gl-program> ;
|
||||
: (solid-sphere-program) ( -- program )
|
||||
sphere-vertex-shader <vertex-shader> check-gl-shader
|
||||
sphere-solid-color-fragment-shader <fragment-shader> check-gl-shader
|
||||
sphere-main-fragment-shader <fragment-shader> check-gl-shader
|
||||
3array <gl-program> check-gl-program ;
|
||||
: (texture-sphere-program) ( -- program )
|
||||
sphere-vertex-shader <vertex-shader> check-gl-shader
|
||||
sphere-texture-fragment-shader <fragment-shader> check-gl-shader
|
||||
sphere-main-fragment-shader <fragment-shader> check-gl-shader
|
||||
3array <gl-program> check-gl-program ;
|
||||
|
||||
M: spheres-gadget graft* ( gadget -- )
|
||||
(plane-program) >>plane-program
|
||||
(solid-sphere-program) >>solid-sphere-program
|
||||
(texture-sphere-program) >>texture-sphere-program
|
||||
(make-reflection-texture) >>reflection-texture
|
||||
(make-reflection-depthbuffer) [ >>reflection-depthbuffer ] keep
|
||||
(make-reflection-framebuffer) >>reflection-framebuffer
|
||||
drop ;
|
||||
|
||||
M: spheres-gadget ungraft* ( gadget -- )
|
||||
{
|
||||
[ reflection-framebuffer>> [ delete-framebuffer ] when* ]
|
||||
[ reflection-depthbuffer>> [ delete-renderbuffer ] when* ]
|
||||
[ reflection-texture>> [ delete-texture ] when* ]
|
||||
[ solid-sphere-program>> [ delete-gl-program ] when* ]
|
||||
[ texture-sphere-program>> [ delete-gl-program ] when* ]
|
||||
[ plane-program>> [ delete-gl-program ] when* ]
|
||||
} cleave ;
|
||||
|
||||
M: spheres-gadget pref-dim* ( gadget -- dim )
|
||||
drop { 640 480 } ;
|
||||
|
||||
: (draw-sphere) ( program center radius surfacecolor -- )
|
||||
roll
|
||||
[ [ "center" glGetAttribLocation swap first3 glVertexAttrib3f ] curry ]
|
||||
[ [ "radius" glGetAttribLocation swap glVertexAttrib1f ] curry ]
|
||||
[ [ "surface_color" glGetAttribLocation swap first4 glVertexAttrib4f ] curry ]
|
||||
tri tri*
|
||||
{ -1.0 -1.0 } { 1.0 1.0 } rect-vertices ;
|
||||
|
||||
: sphere-scene ( gadget -- )
|
||||
GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
|
||||
[
|
||||
solid-sphere-program>> dup {
|
||||
{ "light_position" [ 0.0 0.0 100.0 glUniform3f ] }
|
||||
} [
|
||||
{
|
||||
[ { 7.0 0.0 0.0 } 1.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ]
|
||||
[ { -7.0 0.0 0.0 } 1.0 { 0.0 1.0 0.0 1.0 } (draw-sphere) ]
|
||||
[ { 0.0 0.0 7.0 } 1.0 { 0.0 0.0 1.0 1.0 } (draw-sphere) ]
|
||||
[ { 0.0 0.0 -7.0 } 1.0 { 1.0 1.0 0.0 1.0 } (draw-sphere) ]
|
||||
[ { 0.0 7.0 0.0 } 1.0 { 1.0 0.0 1.0 1.0 } (draw-sphere) ]
|
||||
[ { 0.0 -7.0 0.0 } 1.0 { 0.0 1.0 1.0 1.0 } (draw-sphere) ]
|
||||
} cleave
|
||||
] with-gl-program
|
||||
] [
|
||||
plane-program>> { } [
|
||||
GL_QUADS [
|
||||
-1000.0 -30.0 1000.0 glVertex3f
|
||||
-1000.0 -30.0 -1000.0 glVertex3f
|
||||
1000.0 -30.0 -1000.0 glVertex3f
|
||||
1000.0 -30.0 1000.0 glVertex3f
|
||||
] do-state
|
||||
] with-gl-program
|
||||
] bi ;
|
||||
|
||||
: reflection-frustum ( gadget -- -x x -y y near far )
|
||||
[ near-plane ] [ far-plane ] bi [
|
||||
drop dup [ -+ ] bi@
|
||||
] 2keep ;
|
||||
|
||||
: (reflection-face) ( gadget face -- )
|
||||
swap reflection-texture>> >r >r
|
||||
GL_FRAMEBUFFER_EXT
|
||||
GL_COLOR_ATTACHMENT0_EXT
|
||||
r> r> 0 glFramebufferTexture2DEXT
|
||||
check-framebuffer ;
|
||||
|
||||
: (draw-reflection-texture) ( gadget -- )
|
||||
dup reflection-framebuffer>> [ {
|
||||
[ drop 0 0 (reflection-dim) glViewport ]
|
||||
[
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
reflection-frustum glFrustum
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity
|
||||
180.0 0.0 0.0 1.0 glRotatef
|
||||
]
|
||||
[ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z (reflection-face) ]
|
||||
[ sphere-scene ]
|
||||
[ GL_TEXTURE_CUBE_MAP_POSITIVE_X (reflection-face)
|
||||
90.0 0.0 1.0 0.0 glRotatef ]
|
||||
[ sphere-scene ]
|
||||
[ GL_TEXTURE_CUBE_MAP_POSITIVE_Z (reflection-face)
|
||||
90.0 0.0 1.0 0.0 glRotatef glPushMatrix ]
|
||||
[ sphere-scene ]
|
||||
[ GL_TEXTURE_CUBE_MAP_NEGATIVE_X (reflection-face)
|
||||
90.0 0.0 1.0 0.0 glRotatef ]
|
||||
[ sphere-scene ]
|
||||
[ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y (reflection-face)
|
||||
glPopMatrix glPushMatrix -90.0 1.0 0.0 0.0 glRotatef ]
|
||||
[ sphere-scene ]
|
||||
[ GL_TEXTURE_CUBE_MAP_POSITIVE_Y (reflection-face)
|
||||
glPopMatrix 90.0 1.0 0.0 0.0 glRotatef ]
|
||||
[ sphere-scene ]
|
||||
[ dim>> 0 0 rot first2 glViewport ]
|
||||
} cleave ] with-framebuffer ;
|
||||
|
||||
M: spheres-gadget draw-gadget* ( gadget -- )
|
||||
GL_DEPTH_TEST glEnable
|
||||
GL_SCISSOR_TEST glDisable
|
||||
0.15 0.15 1.0 1.0 glClearColor {
|
||||
[ (draw-reflection-texture) ]
|
||||
[ demo-gadget-set-matrices ]
|
||||
[ sphere-scene ]
|
||||
[ reflection-texture>> GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit ]
|
||||
[
|
||||
texture-sphere-program>> dup {
|
||||
{ "surface_texture" [ 0 glUniform1i ] }
|
||||
} [
|
||||
{ 0.0 0.0 0.0 } 4.0 { 1.0 0.0 0.0 1.0 } (draw-sphere)
|
||||
] with-gl-program
|
||||
]
|
||||
} cleave ;
|
||||
|
||||
: spheres-window ( -- )
|
||||
[ <spheres-gadget> "Spheres" open-window ] with-ui ;
|
||||
|
||||
MAIN: spheres-window
|
||||
|
|
@ -0,0 +1 @@
|
|||
Draw pixel-perfect spheres using GLSL shaders
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
opengl
|
||||
glsl
|
||||
|
|
@ -1,9 +1,14 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser sequences words kernel ;
|
||||
USING: parser sequences words kernel classes.singleton ;
|
||||
IN: symbols
|
||||
|
||||
: SYMBOLS:
|
||||
";" parse-tokens
|
||||
[ create-in dup reset-generic define-symbol ] each ;
|
||||
parsing
|
||||
|
||||
: SINGLETONS:
|
||||
";" parse-tokens
|
||||
[ create-class-in dup save-location define-singleton-class ] each ;
|
||||
parsing
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: threads io.files io.monitors init kernel
|
||||
vocabs vocabs.loader tools.vocabs namespaces continuations
|
||||
sequences splitting assocs command-line ;
|
||||
sequences splitting assocs command-line concurrency.messaging io.backend sets ;
|
||||
IN: tools.vocabs.monitor
|
||||
|
||||
: vocab-dir>vocab-name ( path -- vocab )
|
||||
|
|
@ -22,17 +22,20 @@ IN: tools.vocabs.monitor
|
|||
: path>vocab ( path -- vocab )
|
||||
chop-vocab-root path>vocab-name vocab-dir>vocab-name ;
|
||||
|
||||
: monitor-loop ( monitor -- )
|
||||
: monitor-loop ( -- )
|
||||
#! On OS X, monitors give us the full path, so we chop it
|
||||
#! off if its there.
|
||||
dup next-change drop path>vocab changed-vocab
|
||||
receive first path>vocab changed-vocab
|
||||
reset-cache
|
||||
monitor-loop ;
|
||||
|
||||
: add-monitor-for-path ( path -- )
|
||||
normalize-path dup exists? [ t my-mailbox (monitor) ] when drop ;
|
||||
|
||||
: monitor-thread ( -- )
|
||||
[
|
||||
[
|
||||
"" resource-path t <monitor>
|
||||
vocab-roots get prune [ add-monitor-for-path ] each
|
||||
|
||||
H{ } clone changed-vocabs set-global
|
||||
vocabs [ changed-vocab ] each
|
||||
|
|
|
|||
|
|
@ -259,3 +259,8 @@ SYMBOL: +stopped+
|
|||
] 3curry
|
||||
"Walker on " self thread-name append spawn
|
||||
[ associate-thread ] keep ;
|
||||
|
||||
! For convenience
|
||||
IN: syntax
|
||||
|
||||
: B break ;
|
||||
|
|
|
|||
|
|
@ -30,13 +30,13 @@ INSTANCE: splay tree-mixin
|
|||
drop dup node-right swapd r> swap ;
|
||||
|
||||
: cmp ( key node -- obj node -1/0/1 )
|
||||
2dup node-key <=> ;
|
||||
2dup node-key key-side ;
|
||||
|
||||
: lcmp ( key node -- obj node -1/0/1 )
|
||||
2dup node-left node-key <=> ;
|
||||
2dup node-left node-key key-side ;
|
||||
|
||||
: rcmp ( key node -- obj node -1/0/1 )
|
||||
2dup node-right node-key <=> ;
|
||||
2dup node-right node-key key-side ;
|
||||
|
||||
DEFER: (splay)
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel generic math sequences arrays io namespaces
|
||||
prettyprint.private kernel.private assocs random combinators
|
||||
parser prettyprint.backend math.order ;
|
||||
parser prettyprint.backend math.order accessors ;
|
||||
IN: trees
|
||||
|
||||
MIXIN: tree-mixin
|
||||
|
|
@ -25,19 +25,24 @@ TUPLE: node key value left right ;
|
|||
|
||||
SYMBOL: current-side
|
||||
|
||||
: left -1 ; inline
|
||||
: right 1 ; inline
|
||||
: left ( -- symbol ) -1 ; inline
|
||||
: right ( -- symbol ) 1 ; inline
|
||||
|
||||
: go-left? ( -- ? ) current-side get left = ;
|
||||
: key-side ( k1 k2 -- n )
|
||||
<=> {
|
||||
{ +lt+ [ -1 ] }
|
||||
{ +eq+ [ 0 ] }
|
||||
{ +gt+ [ 1 ] }
|
||||
} case ;
|
||||
|
||||
: inc-count ( tree -- )
|
||||
dup tree-count 1+ swap set-tree-count ;
|
||||
: go-left? ( -- ? ) current-side get left eq? ;
|
||||
|
||||
: dec-count ( tree -- )
|
||||
dup tree-count 1- swap set-tree-count ;
|
||||
: inc-count ( tree -- ) [ 1+ ] change-count drop ;
|
||||
|
||||
: dec-count ( tree -- ) [ 1- ] change-count drop ;
|
||||
|
||||
: node-link@ ( node ? -- node )
|
||||
go-left? xor [ node-left ] [ node-right ] if ;
|
||||
go-left? xor [ left>> ] [ right>> ] if ;
|
||||
: set-node-link@ ( left parent ? -- )
|
||||
go-left? xor [ set-node-left ] [ set-node-right ] if ;
|
||||
|
||||
|
|
@ -47,19 +52,16 @@ SYMBOL: current-side
|
|||
: set-node+link ( child node -- ) t set-node-link@ ;
|
||||
|
||||
: with-side ( side quot -- ) [ swap current-side set call ] with-scope ; inline
|
||||
: with-other-side ( quot -- ) current-side get neg swap with-side ; inline
|
||||
: with-other-side ( quot -- )
|
||||
current-side get neg swap with-side ; inline
|
||||
: go-left ( quot -- ) left swap with-side ; inline
|
||||
: go-right ( quot -- ) right swap with-side ; inline
|
||||
|
||||
: change-root ( tree quot -- )
|
||||
swap [ tree-root swap call ] keep set-tree-root ; inline
|
||||
swap [ root>> swap call ] keep set-tree-root ; inline
|
||||
|
||||
: leaf? ( node -- ? )
|
||||
dup node-left swap node-right or not ;
|
||||
|
||||
: key-side ( k1 k2 -- side )
|
||||
#! side is -1 if k1 < k2, 0 if they are equal, or 1 if k1 > k2
|
||||
<=> sgn ;
|
||||
[ left>> ] [ right>> ] bi or not ;
|
||||
|
||||
: random-side ( -- side ) left right 2array random ;
|
||||
|
||||
|
|
@ -76,11 +78,11 @@ SYMBOL: current-side
|
|||
] [ drop f f ] if* ;
|
||||
|
||||
M: tree at* ( key tree -- value ? )
|
||||
tree-root node-at* ;
|
||||
root>> node-at* ;
|
||||
|
||||
: node-set ( value key node -- node )
|
||||
2dup node-key key-side dup zero? [
|
||||
drop nip [ set-node-value ] keep
|
||||
2dup key>> key-side dup 0 eq? [
|
||||
drop nip swap >>value
|
||||
] [
|
||||
[
|
||||
[ node-link [ node-set ] [ swap <node> ] if* ] keep
|
||||
|
|
@ -93,12 +95,12 @@ M: tree set-at ( value key tree -- )
|
|||
|
||||
: valid-node? ( node -- ? )
|
||||
[
|
||||
dup dup node-left [ node-key swap node-key before? ] when* >r
|
||||
dup dup node-right [ node-key swap node-key after? ] when* r> and swap
|
||||
dup node-left valid-node? swap node-right valid-node? and and
|
||||
dup dup left>> [ node-key swap node-key before? ] when* >r
|
||||
dup dup right>> [ node-key swap node-key after? ] when* r> and swap
|
||||
dup left>> valid-node? swap right>> valid-node? and and
|
||||
] [ t ] if* ;
|
||||
|
||||
: valid-tree? ( tree -- ? ) tree-root valid-node? ;
|
||||
: valid-tree? ( tree -- ? ) root>> valid-node? ;
|
||||
|
||||
: tree-call ( node call -- )
|
||||
>r [ node-key ] keep node-value r> call ; inline
|
||||
|
|
@ -107,20 +109,20 @@ M: tree set-at ( value key tree -- )
|
|||
{
|
||||
{ [ over not ] [ 2drop f f f ] }
|
||||
{ [ [
|
||||
>r node-left r> find-node
|
||||
>r left>> r> find-node
|
||||
] 2keep rot ]
|
||||
[ 2drop t ] }
|
||||
{ [ >r 2nip r> [ tree-call ] 2keep rot ]
|
||||
[ drop [ node-key ] keep node-value t ] }
|
||||
[ >r node-right r> find-node ]
|
||||
[ >r right>> r> find-node ]
|
||||
} cond ; inline
|
||||
|
||||
M: tree-mixin assoc-find ( tree quot -- key value ? )
|
||||
>r tree-root r> find-node ;
|
||||
>r root>> r> find-node ;
|
||||
|
||||
M: tree-mixin clear-assoc
|
||||
0 over set-tree-count
|
||||
f swap set-tree-root ;
|
||||
0 >>count
|
||||
f >>root drop ;
|
||||
|
||||
: copy-node-contents ( new old -- )
|
||||
dup node-key pick set-node-key node-value swap set-node-value ;
|
||||
|
|
@ -158,22 +160,22 @@ DEFER: delete-node
|
|||
|
||||
: delete-node ( node -- node )
|
||||
#! delete this node, returning its replacement
|
||||
dup node-left [
|
||||
dup node-right [
|
||||
dup left>> [
|
||||
dup right>> [
|
||||
delete-node-with-two-children
|
||||
] [
|
||||
node-left ! left but no right
|
||||
left>> ! left but no right
|
||||
] if
|
||||
] [
|
||||
dup node-right [
|
||||
node-right ! right but not left
|
||||
dup right>> [
|
||||
right>> ! right but not left
|
||||
] [
|
||||
drop f ! no children
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: delete-bst-node ( key node -- node )
|
||||
2dup node-key key-side dup zero? [
|
||||
2dup node-key key-side dup 0 eq? [
|
||||
drop nip delete-node
|
||||
] [
|
||||
[ tuck node-link delete-bst-node over set-node-link ] with-side
|
||||
|
|
@ -197,7 +199,7 @@ M: tree-mixin assoc-like drop dup tree? [ >tree ] unless ;
|
|||
|
||||
M: tree pprint-delims drop \ TREE{ \ } ;
|
||||
|
||||
M: tree-mixin assoc-size tree-count ;
|
||||
M: tree-mixin assoc-size count>> ;
|
||||
M: tree-mixin clone dup assoc-clone-like ;
|
||||
M: tree-mixin >pprint-sequence >alist ;
|
||||
M: tree-mixin pprint-narrow? drop t ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays hashtables kernel models math namespaces sequences
|
||||
quotations math.vectors combinators sorting vectors dlists
|
||||
models threads concurrency.flags ;
|
||||
models threads concurrency.flags math.order ;
|
||||
IN: ui.gadgets
|
||||
|
||||
SYMBOL: ui-notify-flag
|
||||
|
|
@ -106,7 +106,7 @@ GENERIC: children-on ( rect/point gadget -- seq )
|
|||
M: gadget children-on nip gadget-children ;
|
||||
|
||||
: (fast-children-on) ( dim axis gadgets -- i )
|
||||
swapd [ rect-loc v- over v. ] binsearch nip ;
|
||||
swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ;
|
||||
|
||||
: fast-children-on ( rect axis children -- from to )
|
||||
3dup
|
||||
|
|
|
|||
|
|
@ -22,7 +22,8 @@ IN: update
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: remote-clean-image ( -- url )
|
||||
"http://factorcode.org/images/clean/" my-boot-image-name append ;
|
||||
{ "http://factorcode.org/images/clean/" platform "/" my-boot-image-name }
|
||||
to-string ;
|
||||
|
||||
: download-clean-image ( -- ) remote-clean-image download ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,53 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.files io.encodings.ascii sequences sequences.lib
|
||||
math.parser combinators kernel memoize csv symbols inspector
|
||||
words accessors math.order sorting ;
|
||||
IN: usa-cities
|
||||
|
||||
SINGLETONS: AK AL AR AS AZ CA CO CT DC DE FL GA HI IA ID IL IN
|
||||
KS KY LA MA MD ME MI MN MO MS MT NC ND NE NH NJ NM NV NY OH OK
|
||||
OR PA PR RI SC SD TN TX UT VA VI VT WA WI WV WY ;
|
||||
|
||||
: states ( -- seq )
|
||||
{
|
||||
AK AL AR AS AZ CA CO CT DC DE FL GA HI IA ID IL IN KS KY
|
||||
LA MA MD ME MI MN MO MS MT NC ND NE NH NJ NM NV NY OH OK
|
||||
OR PA PR RI SC SD TN TX UT VA VI VT WA WI WV WY
|
||||
} ; inline
|
||||
|
||||
ERROR: no-such-state name ;
|
||||
|
||||
M: no-such-state summary drop "No such state" ;
|
||||
|
||||
MEMO: string>state ( string -- state )
|
||||
dup states [ word-name = ] with find nip
|
||||
[ ] [ no-such-state ] ?if ;
|
||||
|
||||
TUPLE: city
|
||||
first-zip name state latitude longitude gmt-offset dst-offset ;
|
||||
|
||||
MEMO: cities ( -- seq )
|
||||
"resource:extra/usa-cities/zipcode.csv" ascii <file-reader>
|
||||
csv rest-slice [
|
||||
7 firstn {
|
||||
[ string>number ]
|
||||
[ ]
|
||||
[ string>state ]
|
||||
[ string>number ]
|
||||
[ string>number ]
|
||||
[ string>number ]
|
||||
[ string>number ]
|
||||
} spread city boa
|
||||
] map ;
|
||||
|
||||
MEMO: cities-named ( name -- cities )
|
||||
cities [ name>> = ] with filter ;
|
||||
|
||||
MEMO: cities-named-in ( name state -- cities )
|
||||
cities [
|
||||
tuck [ name>> = ] [ state>> = ] 2bi* and
|
||||
] with with filter ;
|
||||
|
||||
: find-zip-code ( code -- city )
|
||||
cities [ first-zip>> <=> ] binsearch* ;
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,29 @@
|
|||
USING: math kernel accessors http.server http.server.actions
|
||||
http.server.sessions http.server.templating.fhtml locals ;
|
||||
IN: webapps.counter
|
||||
|
||||
SYMBOL: count
|
||||
|
||||
TUPLE: counter-app < dispatcher ;
|
||||
|
||||
M: counter-app init-session*
|
||||
drop 0 count sset ;
|
||||
|
||||
:: <counter-action> ( quot -- action )
|
||||
<action> [
|
||||
count quot schange
|
||||
"" f <standard-redirect>
|
||||
] >>display ;
|
||||
|
||||
: <display-action> ( -- action )
|
||||
<action> [
|
||||
"text/html" <content>
|
||||
"resource:extra/webapps/counter/counter.fhtml" <fhtml> >>body
|
||||
] >>display ;
|
||||
|
||||
: <counter-app> ( -- responder )
|
||||
counter-app new-dispatcher
|
||||
[ 1+ ] <counter-action> "inc" add-responder
|
||||
[ 1- ] <counter-action> "dec" add-responder
|
||||
<display-action> "" add-responder
|
||||
<sessions> ;
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
<% USING: io math.parser http.server.sessions webapps.counter ; %>
|
||||
|
||||
<html>
|
||||
<body>
|
||||
<h1><% count sget number>string write %></h1>
|
||||
|
||||
<a href="inc">++</a>
|
||||
<a href="dec">--</a>
|
||||
</body>
|
||||
</html>
|
||||
|
|
@ -6,9 +6,9 @@ http.server
|
|||
http.server.db
|
||||
http.server.flows
|
||||
http.server.sessions
|
||||
http.server.auth.admin
|
||||
http.server.auth.login
|
||||
http.server.auth.providers.db
|
||||
http.server.sessions.storage.db
|
||||
http.server.boilerplate
|
||||
http.server.templating.chloe
|
||||
webapps.pastebin
|
||||
|
|
@ -16,7 +16,7 @@ webapps.planet
|
|||
webapps.todo ;
|
||||
IN: webapps.factor-website
|
||||
|
||||
: test-db "test.db" resource-path sqlite-db ;
|
||||
: test-db "resource:test.db" sqlite-db ;
|
||||
|
||||
: factor-template ( path -- template )
|
||||
"resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
|
||||
|
|
@ -39,6 +39,7 @@ IN: webapps.factor-website
|
|||
<todo-list> "todo" add-responder
|
||||
<pastebin> "pastebin" add-responder
|
||||
<planet-factor> "planet" add-responder
|
||||
<user-admin> "user-admin" add-responder
|
||||
<login>
|
||||
users-in-db >>users
|
||||
allow-registration
|
||||
|
|
@ -47,8 +48,7 @@ IN: webapps.factor-website
|
|||
<boilerplate>
|
||||
"page" factor-template >>template
|
||||
<flows>
|
||||
<session-manager>
|
||||
sessions-in-db >>sessions
|
||||
<sessions>
|
||||
test-db <db-persistence> ;
|
||||
|
||||
: init-factor-website ( -- )
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ TUPLE: paste id summary author mode date contents annotations captcha ;
|
|||
|
||||
paste "PASTE"
|
||||
{
|
||||
{ "id" "ID" INTEGER +native-id+ }
|
||||
{ "id" "ID" INTEGER +db-assigned-id+ }
|
||||
{ "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
|
||||
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
|
||||
{ "mode" "MODE" { VARCHAR 256 } +not-null+ }
|
||||
|
|
@ -43,7 +43,7 @@ TUPLE: annotation aid id summary author mode contents date captcha ;
|
|||
|
||||
annotation "ANNOTATION"
|
||||
{
|
||||
{ "aid" "AID" INTEGER +native-id+ }
|
||||
{ "aid" "AID" INTEGER +db-assigned-id+ }
|
||||
{ "id" "ID" INTEGER +not-null+ }
|
||||
{ "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
|
||||
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
|
||||
|
|
@ -197,9 +197,9 @@ annotation "ANNOTATION"
|
|||
{ { "id" [ v-number ] } } >>post-params
|
||||
|
||||
[
|
||||
"id" get ctor call delete-tuple
|
||||
"id" get ctor call delete-tuples
|
||||
|
||||
"id" get f <annotation> select-tuples [ delete-tuple ] each
|
||||
"id" get f <annotation> delete-tuples
|
||||
|
||||
next f <permanent-redirect>
|
||||
] >>submit ;
|
||||
|
|
@ -209,7 +209,7 @@ annotation "ANNOTATION"
|
|||
{ { "id" [ v-number ] } { "aid" [ v-number ] } } >>post-params
|
||||
|
||||
[
|
||||
"id" get "aid" get ctor call delete-tuple
|
||||
"id" get "aid" get ctor call delete-tuples
|
||||
|
||||
"id" get next <id-redirect>
|
||||
] >>submit ;
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue