steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix conflict

db4
Slava Pestov 2008-10-17 18:46:56 -05:00
parent a57320997a 3ca9fc926e
commit 7d6e919929
24 changed files with 390 additions and 135 deletions

65
basis/cocoa/messages/messages.factor
View File

@ -108,22 +108,34 @@ H{
{ "c" "char" }
{ "i" "int" }
{ "s" "short" }
{ "l" "long" }
{ "q" "longlong" }
{ "C" "uchar" }
{ "I" "uint" }
{ "S" "ushort" }
{ "L" "ulong" }
{ "Q" "ulonglong" }
{ "f" "float" }
{ "d" "double" }
{ "B" "bool" }
{ "v" "void" }
{ "*" "char*" }
{ "?" "unknown_type" }
{ "@" "id" }
{ "#" "id" }
{ "#" "Class" }
{ ":" "SEL" }
} objc>alien-types set-global
}
"ptrdiff_t" heap-size {
{ 4 [ H{
{ "l" "long" }
{ "q" "longlong" }
{ "L" "ulong" }
{ "Q" "ulonglong" }
} ] }
{ 8 [ H{
{ "l" "long32" }
{ "q" "long" }
{ "L" "ulong32" }
{ "Q" "ulong" }
} ] }
} case
assoc-union objc>alien-types set-global
! The transpose of the above map
SYMBOL: alien>objc-types
@ -132,16 +144,22 @@ objc>alien-types get [ swap ] assoc-map
! A hack...
"ptrdiff_t" heap-size {
{ 4 [ H{
{ "NSPoint" "{_NSPoint=ff}" }
{ "NSRect" "{_NSRect=ffff}" }
{ "NSSize" "{_NSSize=ff}" }
{ "NSRange" "{_NSRange=II}" }
{ "NSPoint" "{_NSPoint=ff}" }
{ "NSRect" "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
{ "NSSize" "{_NSSize=ff}" }
{ "NSRange" "{_NSRange=II}" }
{ "NSInteger" "i" }
{ "NSUInteger" "I" }
{ "CGFloat" "f" }
} ] }
{ 8 [ H{
{ "NSPoint" "{_NSPoint=dd}" }
{ "NSRect" "{_NSRect=dddd}" }
{ "NSSize" "{_NSSize=dd}" }
{ "NSRange" "{_NSRange=QQ}" }
{ "NSPoint" "{CGPoint=dd}" }
{ "NSRect" "{CGRect={CGPoint=dd}{CGSize=dd}}" }
{ "NSSize" "{CGSize=dd}" }
{ "NSRange" "{_NSRange=QQ}" }
{ "NSInteger" "q" }
{ "NSUInteger" "Q" }
{ "CGFloat" "d" }
} ] }
} case
assoc-union alien>objc-types set-global
@ -184,12 +202,23 @@ assoc-union alien>objc-types set-global
swap method_getName sel_getName
objc-methods get set-at ;
: (register-objc-methods) ( methods count -- methods )
over [ void*-nth register-objc-method ] curry each ;
: each-method-in-class ( class quot -- )
[ 0 <uint> [ class_copyMethodList ] keep *uint over ] dip
'[ _ void*-nth @ ] each (free) ; inline
: register-objc-methods ( class -- )
0 <uint> [ class_copyMethodList ] keep *uint
(register-objc-methods) (free) ;
[ register-objc-method ] each-method-in-class ;
: method. ( method -- )
{
[ method_getName sel_getName ]
[ method-return-type ]
[ method-arg-types ]
[ method_getImplementation ]
} cleave 4array . ;
: methods. ( class -- )
[ method. ] each-method-in-class ;
: class-exists? ( string -- class ) objc_getClass >boolean ;

5
basis/cocoa/runtime/runtime.factor
View File

@ -9,7 +9,7 @@ TYPEDEF: void* id
FUNCTION: char* sel_getName ( SEL aSelector ) ;
FUNCTION: bool sel_isMapped ( SEL aSelector ) ;
FUNCTION: char sel_isMapped ( SEL aSelector ) ;
FUNCTION: SEL sel_registerName ( char* str ) ;
@ -54,6 +54,8 @@ FUNCTION: Method* class_copyMethodList ( Class class, uint* outCount ) ;
FUNCTION: Class class_getSuperclass ( Class cls ) ;
FUNCTION: char* class_getName ( Class cls ) ;
FUNCTION: char class_addMethod ( Class class, SEL name, void* imp, void* types ) ;
FUNCTION: char class_addProtocol ( Class class, Protocol protocol ) ;
@ -73,5 +75,6 @@ FUNCTION: void* method_getTypeEncoding ( Method method ) ;
FUNCTION: SEL method_getName ( Method method ) ;
FUNCTION: void* method_setImplementation ( Method method, void* imp ) ;
FUNCTION: void* method_getImplementation ( Method method ) ;
FUNCTION: Class object_getClass ( id object ) ;

9
basis/cocoa/subclassing/subclassing.factor
View File

@ -12,12 +12,17 @@ IN: cocoa.subclassing
[ sel_registerName ] [ execute ] [ ascii string>alien ]
tri* ;
: throw-if-false ( YES/NO -- )
zero? [ "Failed to add method or protocol to class" throw ]
when ;
: add-methods ( methods class -- )
swap
[ init-method class_addMethod drop ] with each ;
[ init-method class_addMethod throw-if-false ] with each ;
: add-protocols ( protocols class -- )
swap [ objc-protocol class_addProtocol drop ] with each ;
swap [ objc-protocol class_addProtocol throw-if-false ]
with each ;
: (define-objc-class) ( protocols superclass name imeth -- )
-rot

60
basis/cocoa/types/types.factor
View File

@ -10,25 +10,6 @@ TYPEDEF: ulong NSUInteger
{ 8 [ "double" ] }
} case "CGFloat" typedef >>
C-STRUCT: NSRect
{ "CGFloat" "x" }
{ "CGFloat" "y" }
{ "CGFloat" "w" }
{ "CGFloat" "h" } ;
TYPEDEF: NSRect _NSRect
TYPEDEF: NSRect CGRect
: <NSRect> ( x y w h -- rect )
"NSRect" <c-object>
[ set-NSRect-h ] keep
[ set-NSRect-w ] keep
[ set-NSRect-y ] keep
[ set-NSRect-x ] keep ;
: NSRect-x-y ( alien -- origin-x origin-y )
[ NSRect-x ] keep NSRect-y ;
C-STRUCT: NSPoint
{ "CGFloat" "x" }
{ "CGFloat" "y" } ;
@ -47,19 +28,58 @@ C-STRUCT: NSSize
TYPEDEF: NSSize _NSSize
TYPEDEF: NSSize CGSize
TYPEDEF: NSPoint CGPoint
: <NSSize> ( w h -- size )
"NSSize" <c-object>
[ set-NSSize-h ] keep
[ set-NSSize-w ] keep ;
C-STRUCT: NSRect
{ "NSPoint" "origin" }
{ "NSSize" "size" } ;
TYPEDEF: NSRect _NSRect
TYPEDEF: NSRect CGRect
: NSRect-x ( NSRect -- x )
NSRect-origin NSPoint-x ; inline
: NSRect-y ( NSRect -- y )
NSRect-origin NSPoint-y ; inline
: NSRect-w ( NSRect -- w )
NSRect-size NSSize-w ; inline
: NSRect-h ( NSRect -- h )
NSRect-size NSSize-h ; inline
: set-NSRect-x ( x NSRect -- )
NSRect-origin set-NSPoint-x ; inline
: set-NSRect-y ( y NSRect -- )
NSRect-origin set-NSPoint-y ; inline
: set-NSRect-w ( w NSRect -- )
NSRect-size set-NSSize-w ; inline
: set-NSRect-h ( h NSRect -- )
NSRect-size set-NSSize-h ; inline
: <NSRect> ( x y w h -- rect )
"NSRect" <c-object>
[ set-NSRect-h ] keep
[ set-NSRect-w ] keep
[ set-NSRect-y ] keep
[ set-NSRect-x ] keep ;
: NSRect-x-y ( alien -- origin-x origin-y )
[ NSRect-x ] keep NSRect-y ;
C-STRUCT: NSRange
{ "NSUInteger" "location" }
{ "NSUInteger" "length" } ;
TYPEDEF: NSRange _NSRange
! The "lL" type encodings refer to 32-bit values even in 64-bit mode
TYPEDEF: int long32
TYPEDEF: uint ulong32
TYPEDEF: void* unknown_type
: <NSRange> ( length location -- size )
"NSRange" <c-object>
[ set-NSRange-length ] keep

1
basis/db/postgresql/postgresql.factor
View File

@ -230,6 +230,7 @@ M: postgresql-db persistent-table ( -- hashtable )
{ +foreign-id+ { f f "references" } }
{ +on-update+ { f f "on update" } }
{ +on-delete+ { f f "on delete" } }
{ +restrict+ { f f "restrict" } }
{ +cascade+ { f f "cascade" } }

3
basis/db/queries/queries.factor
View File

@ -114,6 +114,9 @@ M: sequence where ( spec obj -- )
[ " or " 0% ] [ dupd where ] interleave drop
] in-parens ;
M: NULL where ( spec obj -- )
drop column-name>> 0% " is NULL" 0% ;
: object-where ( spec obj -- )
over column-name>> 0% " = " 0% bind# ;

1
basis/db/sqlite/sqlite.factor
View File

@ -178,6 +178,7 @@ M: sqlite-db persistent-table ( -- assoc )
{ +random-id+ { "integer" "integer" f } }
{ +foreign-id+ { "integer" "integer" "references" } }
{ +on-update+ { f f "on update" } }
{ +on-delete+ { f f "on delete" } }
{ +restrict+ { f f "restrict" } }
{ +cascade+ { f f "cascade" } }

2
basis/db/tuples/tuples-docs.factor
View File

@ -229,7 +229,7 @@ T{ book
"Now we've created a book. Let's save it to the database."
{ $code <" USING: db db.sqlite fry io.files ;
: with-book-tutorial ( quot -- )
'[ "book-tutorial.db" temp-file sqlite-db _ with-db ] call ;
'[ "book-tutorial.db" temp-file <sqlite-db> _ with-db ] call ;
[
book recreate-table

7
basis/db/tuples/tuples-tests.factor
View File

@ -472,7 +472,12 @@ TUPLE: exam id name score ;
T{ exam } select-tuples
] unit-test
[ 4 ] [ T{ exam } count-tuples ] unit-test ;
[ 4 ] [ T{ exam } count-tuples ] unit-test
[ ] [ T{ exam { score 10 } } insert-tuple ] unit-test
[ 10 ]
[ T{ exam { name NULL } } select-tuples first score>> ] unit-test ;
TUPLE: bignum-test id m n o ;
: <bignum-test> ( m n o -- obj )

6
basis/db/types/types.factor
View File

@ -26,8 +26,8 @@ SINGLETONS: +db-assigned-id+ +user-assigned-id+ +random-id+ ;
UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
+foreign-id+ +has-many+ +on-delete+ +restrict+ +cascade+ +set-null+
+set-default+ ;
+foreign-id+ +has-many+ +on-update+ +on-delete+ +restrict+ +cascade+
+set-null+ +set-default+ ;
SYMBOL: IGNORE
@ -91,7 +91,7 @@ ERROR: not-persistent class ;
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
SINGLETONS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
FACTOR-BLOB NULL URL ;

3
basis/editors/editors.factor
View File

@ -27,7 +27,8 @@ SYMBOL: edit-hook
: edit-location ( file line -- )
>r (normalize-path) r>
edit-hook get [ call ] [ no-edit-hook edit-location ] if* ;
edit-hook get-global
[ call ] [ no-edit-hook edit-location ] if* ;
: edit ( defspec -- )
where [ first2 edit-location ] when* ;

70
basis/locals/locals-tests.factor
View File

@ -1,7 +1,7 @@
USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart math.order ;
combinators.short-circuit.smart math.order math.functions ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
@ -305,17 +305,29 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
[ f ] [ 8 &&-test ] unit-test
[ t ] [ 12 &&-test ] unit-test
:: wlet-&&-test ( a -- ? )
[wlet | is-integer? [ a integer? ]
is-even? [ a even? ]
>10? [ a 10 > ] |
{ [ is-integer? ] [ is-even? ] [ >10? ] } &&
:: let-and-cond-test-1 ( -- a )
[let | a [ 10 ] |
[let | a [ 20 ] |
{
{ [ t ] [ [let | c [ 30 ] | a ] ] }
} cond
]
] ;
! [ f ] [ 1.5 wlet-&&-test ] unit-test
! [ f ] [ 3 wlet-&&-test ] unit-test
! [ f ] [ 8 wlet-&&-test ] unit-test
! [ t ] [ 12 wlet-&&-test ] unit-test
\ let-and-cond-test-1 must-infer
[ 20 ] [ let-and-cond-test-1 ] unit-test
:: let-and-cond-test-2 ( -- pair )
[let | A [ 10 ] |
[let | B [ 20 ] |
{ { [ t ] [ { A B } ] } } cond
]
] ;
\ let-and-cond-test-2 must-infer
[ { 10 20 } ] [ let-and-cond-test-2 ] unit-test
[ { 10 } ] [ 10 [| a | { a } ] call ] unit-test
[ { 10 20 } ] [ 10 20 [| a b | { a b } ] call ] unit-test
@ -333,6 +345,16 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
{ 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
:: literal-identity-test ( -- a b )
{ } V{ } ;
[ t f ] [
literal-identity-test
literal-identity-test
swapd [ eq? ] [ eq? ] 2bi*
] unit-test
:: compare-case ( obj1 obj2 lt-quot eq-quot gt-quot -- )
obj1 obj2 <=> {
{ +lt+ [ lt-quot call ] }
@ -340,4 +362,30 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
{ +gt+ [ gt-quot call ] }
} case ; inline
[ [ ] [ ] [ ] compare-case ] must-infer
[ [ ] [ ] [ ] compare-case ] must-infer
:: big-case-test ( a -- b )
a {
{ 0 [ a 1 + ] }
{ 1 [ a 1 - ] }
{ 2 [ a 1 swap / ] }
{ 3 [ a dup * ] }
{ 4 [ a sqrt ] }
{ 5 [ a a ^ ] }
} case ;
\ big-case-test must-infer
[ 9 ] [ 3 big-case-test ] unit-test
! :: wlet-&&-test ( a -- ? )
! [wlet | is-integer? [ a integer? ]
! is-even? [ a even? ]
! >10? [ a 10 > ] |
! { [ is-integer? ] [ is-even? ] [ >10? ] } &&
! ] ;
! [ f ] [ 1.5 wlet-&&-test ] unit-test
! [ f ] [ 3 wlet-&&-test ] unit-test
! [ f ] [ 8 wlet-&&-test ] unit-test
! [ t ] [ 12 wlet-&&-test ] unit-test

35
basis/locals/locals.factor
View File

@ -35,11 +35,15 @@ C: <wlet> wlet
M: lambda expand-macros clone [ expand-macros ] change-body ;
M: lambda expand-macros* expand-macros literal ;
M: binding-form expand-macros
clone
[ [ expand-macros ] assoc-map ] change-bindings
[ expand-macros ] change-body ;
M: binding-form expand-macros* expand-macros literal ;
PREDICATE: local < word "local?" word-prop ;
: <local> ( name -- word )
@ -142,12 +146,12 @@ GENERIC: free-vars* ( form -- )
[ free-vars* ] { } make prune ;
: add-if-free ( object -- )
{
{ [ dup local-writer? ] [ "local-reader" word-prop , ] }
{ [ dup lexical? ] [ , ] }
{ [ dup quote? ] [ local>> , ] }
{ [ t ] [ free-vars* ] }
} cond ;
{
{ [ dup local-writer? ] [ "local-reader" word-prop , ] }
{ [ dup lexical? ] [ , ] }
{ [ dup quote? ] [ local>> , ] }
{ [ t ] [ free-vars* ] }
} cond ;
M: object free-vars* drop ;
@ -195,6 +199,20 @@ M: block lambda-rewrite*
swap point-free ,
] keep length \ curry <repetition> % ;
GENERIC: rewrite-literal? ( obj -- ? )
M: special rewrite-literal? drop t ;
M: array rewrite-literal? [ rewrite-literal? ] contains? ;
M: hashtable rewrite-literal? drop t ;
M: vector rewrite-literal? drop t ;
M: tuple rewrite-literal? drop t ;
M: object rewrite-literal? drop f ;
GENERIC: rewrite-element ( obj -- )
: rewrite-elements ( seq -- )
@ -203,7 +221,8 @@ GENERIC: rewrite-element ( obj -- )
: rewrite-sequence ( seq -- )
[ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ;
M: array rewrite-element rewrite-sequence ;
M: array rewrite-element
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
M: vector rewrite-element rewrite-sequence ;
@ -441,7 +460,7 @@ M: lambda-memoized definition
"lambda" word-prop body>> ;
M: lambda-memoized reset-word
[ f "lambda" set-word-prop ] [ call-next-method ] bi ;
[ call-next-method ] [ f "lambda" set-word-prop ] bi ;
: method-stack-effect ( method -- effect )
dup "lambda" word-prop vars>>

29
basis/macros/expander/expander.factor
View File

@ -1,14 +1,12 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences namespaces make quotations accessors
words continuations vectors effects math
stack-checker.transforms ;
USING: kernel sequences sequences.private namespaces make
quotations accessors words continuations vectors effects math
generalizations stack-checker.transforms fry ;
IN: macros.expander
GENERIC: expand-macros ( quot -- quot' )
<PRIVATE
SYMBOL: stack
: begin ( -- ) V{ } clone stack set ;
@ -28,6 +26,17 @@ GENERIC: expand-macros* ( obj -- )
M: wrapper expand-macros* wrapped>> literal ;
: expand-dispatch? ( word -- ? )
\ dispatch eq? stack get length 1 >= and ;
: expand-dispatch ( -- )
stack get pop end
[ [ expand-macros ] [ ] map-as '[ _ dip ] % ]
[
length [ <reversed> ] keep
[ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
] bi ;
: expand-macro ( quot -- )
stack [ swap with-datastack >vector ] change
stack get pop >quotation end (expand-macros) ;
@ -38,8 +47,14 @@ M: wrapper expand-macros* wrapped>> literal ;
stack get length <=
] [ 2drop f f ] if ;
: word, ( word -- ) end , ;
M: word expand-macros*
dup expand-macro? [ nip expand-macro ] [ drop end , ] if ;
dup expand-dispatch? [ drop expand-dispatch ] [
dup expand-macro? [ nip expand-macro ] [
drop word,
] if
] if ;
M: object expand-macros* literal ;
@ -48,5 +63,3 @@ M: callable expand-macros*
M: callable expand-macros ( quot -- quot' )
[ begin (expand-macros) end ] [ ] make ;
PRIVATE>

32
basis/ui/cocoa/views/views.factor
View File

@ -128,12 +128,12 @@ CLASS: {
}
! Rendering
{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
[ 3drop window relayout-1 ]
{ "drawRect:" "void" { "id" "SEL" "NSRect" }
[ 2drop window relayout-1 ]
}
! Events
{ "acceptsFirstMouse:" "bool" { "id" "SEL" "id" }
{ "acceptsFirstMouse:" "char" { "id" "SEL" "id" }
[ 3drop 1 ]
}
@ -251,7 +251,7 @@ CLASS: {
! "rotateWithEvent:" "void" { "id" "SEL" "id" }}
{ "acceptsFirstResponder" "bool" { "id" "SEL" }
{ "acceptsFirstResponder" "char" { "id" "SEL" }
[ 2drop 1 ]
}
@ -264,26 +264,26 @@ CLASS: {
]
}
{ "writeSelectionToPasteboard:types:" "bool" { "id" "SEL" "id" "id" }
{ "writeSelectionToPasteboard:types:" "char" { "id" "SEL" "id" "id" }
[
CF>string-array NSStringPboardType swap member? [
>r drop window-focus gadget-selection dup [
r> set-pasteboard-string t
r> set-pasteboard-string 1
] [
r> 2drop f
r> 2drop 0
] if
] [
3drop f
3drop 0
] if
]
}
{ "readSelectionFromPasteboard:" "bool" { "id" "SEL" "id" }
{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
[
pasteboard-string dup [
>r drop window-focus r> swap user-input t
>r drop window-focus r> swap user-input 1
] [
3drop f
3drop 0
] if
]
}
@ -293,7 +293,7 @@ CLASS: {
[ [ nip send-user-input ] ui-try ]
}
{ "hasMarkedText" "bool" { "id" "SEL" }
{ "hasMarkedText" "char" { "id" "SEL" }
[ 2drop 0 ]
}
@ -321,7 +321,7 @@ CLASS: {
[ 3drop f ]
}
{ "characterIndexForPoint:" "uint" { "id" "SEL" "NSPoint" }
{ "characterIndexForPoint:" "NSUInteger" { "id" "SEL" "NSPoint" }
[ 3drop 0 ]
}
@ -329,7 +329,7 @@ CLASS: {
[ 3drop 0 0 0 0 <NSRect> ]
}
{ "conversationIdentifier" "long" { "id" "SEL" }
{ "conversationIdentifier" "NSInteger" { "id" "SEL" }
[ drop alien-address ]
}
@ -394,9 +394,9 @@ CLASS: {
]
}
{ "windowShouldClose:" "bool" { "id" "SEL" "id" }
{ "windowShouldClose:" "char" { "id" "SEL" "id" }
[
3drop t
3drop 1
]
}

21
core/combinators/combinators.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors
hashtables sorting words sets math.order ;
hashtables sorting words sets math.order make ;
IN: combinators
! cleave
@ -116,17 +116,16 @@ ERROR: no-case ;
] [ drop f ] if
] [ drop f ] if ;
: dispatch-case ( value from to default array -- )
>r >r 3dup between? r> r> rot [
>r 2drop - >fixnum r> dispatch
] [
drop 2nip call
] if ; inline
: dispatch-case-quot ( default assoc -- quot )
[ nip keys [ infimum ] [ supremum ] bi ] 2keep
sort-keys values [ >quotation ] map
[ dispatch-case ] 2curry 2curry ;
[
\ dup ,
dup keys [ infimum , ] [ supremum , ] bi \ between? ,
[
dup keys infimum , [ - >fixnum ] %
sort-keys values [ >quotation ] map ,
\ dispatch ,
] [ ] make , , \ if ,
] [ ] make ;
: case>quot ( default assoc -- quot )
dup keys {

12
extra/bind-in/bind-in.factor Normal file
View File

@ -0,0 +1,12 @@
USING: kernel parser lexer locals.private ;
IN: bind-in
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ->
"[" parse-tokens make-locals dup push-locals
\ ] (parse-lambda) <lambda>
parsed-lambda
\ call parsed ; parsing

5
extra/bunny/bunny.factor
View File

@ -1,6 +1,7 @@
USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline
bunny.model bunny.outlined destructors kernel math opengl.demo-support
opengl.gl sequences ui ui.gadgets ui.gestures ui.render words ;
opengl.gl sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
ui.render words ;
IN: bunny
TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ;
@ -18,6 +19,7 @@ TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ;
>>draw-n relayout-1 ;
M: bunny-gadget graft* ( gadget -- )
dup find-gl-context
GL_DEPTH_TEST glEnable
dup model-triangles>> <bunny-geom> >>geom
dup
@ -29,6 +31,7 @@ M: bunny-gadget graft* ( gadget -- )
drop ;
M: bunny-gadget ungraft* ( gadget -- )
dup find-gl-context
[ geom>> [ dispose ] when* ]
[ draw-seq>> [ [ dispose ] when* ] each ] bi ;

35
extra/dns/cache/nx/nx.factor vendored Normal file
View File

@ -0,0 +1,35 @@
USING: kernel assocs locals combinators
math math.functions system unicode.case ;
IN: dns.cache.nx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: nx-cache ( -- table ) H{ } ;
: nx-cache-at ( name -- time ) >lower nx-cache at ;
: nx-cache-delete-at ( name -- ) >lower nx-cache delete-at ;
: nx-cache-set-at ( time name -- ) >lower nx-cache set-at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: now ( -- seconds ) millis 1000.0 / round >integer ;
:: non-existent-name? ( NAME -- ? )
[let | TIME [ NAME nx-cache-at ] |
{
{ [ TIME f = ] [ f ] }
{ [ TIME now <= ] [ NAME nx-cache-delete-at f ] }
{ [ t ] [ t ] }
}
cond
] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: cache-non-existent-name ( NAME TTL -- )
[let | TIME [ TTL now + ] | TIME NAME nx-cache-set-at ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

65
extra/dns/cache/rr/rr.factor vendored Normal file
View File

@ -0,0 +1,65 @@
USING: kernel sequences assocs sets locals combinators
accessors system math math.functions unicode.case prettyprint
combinators.cleave dns ;
IN: dns.cache.rr
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: <entry> time data ;
: now ( -- seconds ) millis 1000.0 / round >integer ;
: expired? ( <entry> -- ? ) time>> now <= ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-cache-key ( obj -- key )
{ [ name>> >lower ] [ type>> unparse ] [ class>> unparse ] } 1arr " " join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cache ( -- table ) H{ } ;
: cache-at ( obj -- ent ) make-cache-key cache at ;
: cache-delete ( obj -- ) make-cache-key cache delete-at ;
: cache-set-at ( ent obj -- ) make-cache-key cache set-at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: cache-get ( OBJ -- rrs/f )
[let | ENT [ OBJ cache-at ] |
{
{ [ ENT f = ] [ f ] }
{ [ ENT expired? ] [ OBJ cache-delete f ] }
{
[ t ]
[
[let | NAME [ OBJ name>> ]
TYPE [ OBJ type>> ]
CLASS [ OBJ class>> ]
TTL [ now ENT time>> - ] |
ENT data>>
[| RDATA | T{ rr f NAME TYPE CLASS TTL RDATA } ]
map
]
]
}
}
cond
] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: cache-add ( RR -- )
[let | ENT [ RR cache-at ]
TIME [ RR ttl>> now + ]
RDATA [ RR rdata>> ] |
{
{ [ ENT f = ] [ T{ <entry> f TIME V{ RDATA } } RR cache-set-at ] }
{ [ ENT expired? ] [ RR cache-delete RR cache-add ] }
{ [ t ] [ TIME ENT (>>time) RDATA ENT data>> adjoin ] }
}
cond
] ;

18
extra/sequences/lib/lib.factor
View File

@ -4,7 +4,8 @@
USING: combinators.lib kernel sequences math namespaces make
assocs random sequences.private shuffle math.functions arrays
math.parser math.private sorting strings ascii macros assocs.lib
quotations hashtables math.order locals generalizations ;
quotations hashtables math.order locals generalizations
math.ranges random ;
IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline
@ -131,11 +132,6 @@ PRIVATE>
: power-set ( seq -- subsets )
2 over length exact-number-strings swap [ switches ] curry map ;
USE: continuations
: ?subseq ( from to seq -- subseq )
>r >r 0 max r> r>
[ length tuck min >r min r> ] keep subseq ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
<PRIVATE
@ -149,18 +145,10 @@ PRIVATE>
: attempt-each ( seq quot -- result )
(each) iterate-prep (attempt-each-integer) ; inline
: ?nth* ( n seq -- elt/f ? )
2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USE: math.ranges
USE: random
: randomize ( seq -- seq' )
dup length 1 (a,b] [ dup random pick exchange ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: enumerate ( seq -- seq' )
<enum> >alist ;
: enumerate ( seq -- seq' ) <enum> >alist ;

37
extra/spheres/spheres.factor
View File

@ -1,6 +1,6 @@
USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers
opengl multiline ui.gadgets accessors sequences ui.render ui math
arrays generalizations combinators ;
opengl multiline ui.gadgets accessors sequences ui.render ui math locals
arrays generalizations combinators opengl.capabilities ui.gadgets.worlds ;
IN: spheres
STRING: plane-vertex-shader
@ -162,6 +162,9 @@ M: spheres-gadget distance-step ( gadget -- dz )
3array <gl-program> check-gl-program ;
M: spheres-gadget graft* ( gadget -- )
dup find-gl-context
"2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions
{ "GL_EXT_framebuffer_object" } require-gl-extensions
(plane-program) >>plane-program
(solid-sphere-program) >>solid-sphere-program
(texture-sphere-program) >>texture-sphere-program
@ -171,6 +174,7 @@ M: spheres-gadget graft* ( gadget -- )
drop ;
M: spheres-gadget ungraft* ( gadget -- )
dup find-gl-context
{
[ reflection-framebuffer>> [ delete-framebuffer ] when* ]
[ reflection-depthbuffer>> [ delete-renderbuffer ] when* ]
@ -182,14 +186,15 @@ M: spheres-gadget ungraft* ( gadget -- )
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*
:: (draw-sphere) ( program center radius -- )
program "center" glGetAttribLocation center first3 glVertexAttrib3f
program "radius" glGetAttribLocation radius glVertexAttrib1f
{ -1.0 -1.0 } { 1.0 1.0 } rect-vertices ;
:: (draw-colored-sphere) ( program center radius surfacecolor -- )
program "surface_color" glGetAttribLocation surfacecolor first4 glVertexAttrib4f
program center radius (draw-sphere) ;
: sphere-scene ( gadget -- )
GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
@ -197,12 +202,12 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
solid-sphere-program>> [
{
[ "light_position" glGetUniformLocation 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) ]
[ { 7.0 0.0 0.0 } 1.0 { 1.0 0.0 0.0 1.0 } (draw-colored-sphere) ]
[ { -7.0 0.0 0.0 } 1.0 { 0.0 1.0 0.0 1.0 } (draw-colored-sphere) ]
[ { 0.0 0.0 7.0 } 1.0 { 0.0 0.0 1.0 1.0 } (draw-colored-sphere) ]
[ { 0.0 0.0 -7.0 } 1.0 { 1.0 1.0 0.0 1.0 } (draw-colored-sphere) ]
[ { 0.0 7.0 0.0 } 1.0 { 1.0 0.0 1.0 1.0 } (draw-colored-sphere) ]
[ { 0.0 -7.0 0.0 } 1.0 { 0.0 1.0 1.0 1.0 } (draw-colored-sphere) ]
} cleave
] with-gl-program
] [
@ -271,7 +276,7 @@ M: spheres-gadget draw-gadget* ( gadget -- )
[
texture-sphere-program>> [
[ "surface_texture" glGetUniformLocation 0 glUniform1i ]
[ { 0.0 0.0 0.0 } 4.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ]
[ { 0.0 0.0 0.0 } 4.0 (draw-sphere) ]
bi
] with-gl-program
]

2
extra/webapps/calculator/calculator.factor
View File

@ -33,7 +33,7 @@ TUPLE: calculator < dispatcher ;
! Deployment example
USING: db.sqlite furnace.alloy namespaces http.server ;
: calculator-db ( -- params db ) "calculator.db" sqlite-db ;
: calculator-db ( -- db ) "calculator.db" <sqlite-db> ;
: run-calculator ( -- )
<calculator>

2
extra/webapps/counter/counter.factor
View File

@ -32,7 +32,7 @@ M: counter-app init-session* drop 0 count sset ;
! Deployment example
USING: db.sqlite furnace.alloy namespaces ;
: counter-db ( -- params db ) "counter.db" sqlite-db ;
: counter-db ( -- db ) "counter.db" <sqlite-db> ;
: run-counter ( -- )
<counter-app>