-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
continuations combinators compiler compiler.alien kernel math
drop "void*"
] unless ;
+ERROR: no-objc-type name ;
+
+: decode-type ( ch -- ctype )
+ 1string dup objc>alien-types get at
+ [ ] [ no-objc-type ] ?if ;
+
: (parse-objc-type) ( i string -- ctype )
[ [ 1+ ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
{ [ dup CHAR: [ = ] [ 3drop "void*" ] }
- [ 2nip 1string objc>alien-types get at ]
+ [ 2nip decode-type ]
} cond ;
: parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
[ 0 <uint> [ class_copyMethodList ] keep *uint ] dip
over 0 = [ 3drop ] [
[ <direct-void*-array> ] dip
- [ each ] [ drop underlying>> (free) ] 2bi
+ [ each ] [ drop (free) ] 2bi
] if ; inline
: register-objc-methods ( class -- )
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: specialized-arrays.int arrays kernel math namespaces make
-cocoa cocoa.messages cocoa.classes cocoa.types sequences
+cocoa cocoa.messages cocoa.classes core-graphics.types sequences
continuations accessors ;
IN: cocoa.views
-: NSOpenGLPFAAllRenderers 1 ;
-: NSOpenGLPFADoubleBuffer 5 ;
-: NSOpenGLPFAStereo 6 ;
-: NSOpenGLPFAAuxBuffers 7 ;
-: NSOpenGLPFAColorSize 8 ;
-: NSOpenGLPFAAlphaSize 11 ;
-: NSOpenGLPFADepthSize 12 ;
-: NSOpenGLPFAStencilSize 13 ;
-: NSOpenGLPFAAccumSize 14 ;
-: NSOpenGLPFAMinimumPolicy 51 ;
-: NSOpenGLPFAMaximumPolicy 52 ;
-: NSOpenGLPFAOffScreen 53 ;
-: NSOpenGLPFAFullScreen 54 ;
-: NSOpenGLPFASampleBuffers 55 ;
-: NSOpenGLPFASamples 56 ;
-: NSOpenGLPFAAuxDepthStencil 57 ;
-: NSOpenGLPFAColorFloat 58 ;
-: NSOpenGLPFAMultisample 59 ;
-: NSOpenGLPFASupersample 60 ;
-: NSOpenGLPFASampleAlpha 61 ;
-: NSOpenGLPFARendererID 70 ;
-: NSOpenGLPFASingleRenderer 71 ;
-: NSOpenGLPFANoRecovery 72 ;
-: NSOpenGLPFAAccelerated 73 ;
-: NSOpenGLPFAClosestPolicy 74 ;
-: NSOpenGLPFARobust 75 ;
-: NSOpenGLPFABackingStore 76 ;
-: NSOpenGLPFAMPSafe 78 ;
-: NSOpenGLPFAWindow 80 ;
-: NSOpenGLPFAMultiScreen 81 ;
-: NSOpenGLPFACompliant 83 ;
-: NSOpenGLPFAScreenMask 84 ;
-: NSOpenGLPFAPixelBuffer 90 ;
-: NSOpenGLPFAAllowOfflineRenderers 96 ;
-: NSOpenGLPFAVirtualScreenCount 128 ;
-
-: kCGLRendererGenericFloatID HEX: 00020400 ;
+CONSTANT: NSOpenGLPFAAllRenderers 1
+CONSTANT: NSOpenGLPFADoubleBuffer 5
+CONSTANT: NSOpenGLPFAStereo 6
+CONSTANT: NSOpenGLPFAAuxBuffers 7
+CONSTANT: NSOpenGLPFAColorSize 8
+CONSTANT: NSOpenGLPFAAlphaSize 11
+CONSTANT: NSOpenGLPFADepthSize 12
+CONSTANT: NSOpenGLPFAStencilSize 13
+CONSTANT: NSOpenGLPFAAccumSize 14
+CONSTANT: NSOpenGLPFAMinimumPolicy 51
+CONSTANT: NSOpenGLPFAMaximumPolicy 52
+CONSTANT: NSOpenGLPFAOffScreen 53
+CONSTANT: NSOpenGLPFAFullScreen 54
+CONSTANT: NSOpenGLPFASampleBuffers 55
+CONSTANT: NSOpenGLPFASamples 56
+CONSTANT: NSOpenGLPFAAuxDepthStencil 57
+CONSTANT: NSOpenGLPFAColorFloat 58
+CONSTANT: NSOpenGLPFAMultisample 59
+CONSTANT: NSOpenGLPFASupersample 60
+CONSTANT: NSOpenGLPFASampleAlpha 61
+CONSTANT: NSOpenGLPFARendererID 70
+CONSTANT: NSOpenGLPFASingleRenderer 71
+CONSTANT: NSOpenGLPFANoRecovery 72
+CONSTANT: NSOpenGLPFAAccelerated 73
+CONSTANT: NSOpenGLPFAClosestPolicy 74
+CONSTANT: NSOpenGLPFARobust 75
+CONSTANT: NSOpenGLPFABackingStore 76
+CONSTANT: NSOpenGLPFAMPSafe 78
+CONSTANT: NSOpenGLPFAWindow 80
+CONSTANT: NSOpenGLPFAMultiScreen 81
+CONSTANT: NSOpenGLPFACompliant 83
+CONSTANT: NSOpenGLPFAScreenMask 84
+CONSTANT: NSOpenGLPFAPixelBuffer 90
+CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96
+CONSTANT: NSOpenGLPFAVirtualScreenCount 128
+
+CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
+
+
+CONSTANT: NSOpenGLCPSwapInterval 222
<PRIVATE
-SYMBOL: +software-renderer+
-SYMBOL: +multisample+
+SYMBOL: software-renderer?
+SYMBOL: multisample?
PRIVATE>
: with-software-renderer ( quot -- )
- t +software-renderer+ pick with-variable ; inline
+ [ t software-renderer? ] dip with-variable ; inline
+
: with-multisample ( quot -- )
- t +multisample+ pick with-variable ; inline
+ [ t multisample? ] dip with-variable ; inline
: <PixelFormat> ( attributes -- pixelfmt )
NSOpenGLPixelFormat -> alloc swap [
%
NSOpenGLPFADepthSize , 16 ,
- +software-renderer+ get [
+ software-renderer? get [
NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
] when
- +multisample+ get [
+ multisample? get [
NSOpenGLPFASupersample ,
NSOpenGLPFASampleBuffers , 1 ,
NSOpenGLPFASamples , 8 ,
] when
0 ,
- ] int-array{ } make underlying>>
+ ] int-array{ } make
-> initWithAttributes:
-> autorelease ;
: <GLView> ( class dim -- view )
- [ -> alloc 0 0 ] dip first2 <NSRect>
+ [ -> alloc 0 0 ] dip first2 <CGRect>
NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array <PixelFormat>
-> initWithFrame:pixelFormat:
dup 1 -> setPostsBoundsChangedNotifications:
: view-dim ( view -- dim )
-> bounds
- dup NSRect-w >fixnum
- swap NSRect-h >fixnum 2array ;
+ [ CGRect-w >fixnum ] [ CGRect-h >fixnum ] bi
+ 2array ;
: mouse-location ( view event -- loc )
[
-> locationInWindow f -> convertPoint:fromView:
- [ NSPoint-x ] [ NSPoint-y ] bi
- ] [ drop -> frame NSRect-h ] 2bi
+ [ CGPoint-x ] [ CGPoint-y ] bi
+ ] [ drop -> frame CGRect-h ] 2bi
swap - 2array ;
-
-USE: opengl.gl
-USE: alien.syntax
-
-: NSOpenGLCPSwapInterval 222 ;
-
-LIBRARY: OpenGL
-
-TYPEDEF: int CGLError
-TYPEDEF: void* CGLContextObj
-TYPEDEF: int CGLContextParameter
-
-FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
-
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel assocs io io.styles math math.order math.parser
- sequences strings make words combinators macros xml.literals html fry
+ sequences strings make words combinators macros xml.syntax html fry
destructors ;
IN: html.streams
{
{ foreground fg-css, }
{ background bg-css, }
- { font font-css, }
+ { font-name font-css, }
{ font-style style-css, }
{ font-size size-css, }
} make-css ;
classes.tuple assocs splitting words arrays memoize parser lexer
io io.files io.encodings.utf8 io.streams.string
unicode.case mirrors fry math urls
- multiline xml xml.data xml.writer xml.utilities
+ multiline xml xml.data xml.writer xml.syntax
html.components
html.templates ;
XML-NS: chloe-name http://factorcode.org/chloe/1.0
: required-attr ( tag name -- value )
- tuck chloe-name attr
- [ nip ] [ " attribute is required" append throw ] if* ;
+ [ nip ] [ chloe-name attr ] 2bi
+ [ ] [ " attribute is required" append throw ] ?if ;
: optional-attr ( tag name -- value )
chloe-name attr ;
! Copyright (C) 2004, 2005 Mackenzie Straight
-! Copyright (C) 2007, 2008 Slava Pestov
+! Copyright (C) 2007, 2009 Slava Pestov
! Copyright (C) 2007, 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
-USING: alien assocs continuations destructors kernel
+USING: alien assocs continuations alien.destructors kernel
namespaces accessors sets summary ;
IN: libc
<PRIVATE
-: add-malloc ( alien -- )
- mallocs conjoin ;
+: add-malloc ( alien -- alien )
+ dup mallocs conjoin ;
: delete-malloc ( alien -- )
[
mallocs delete-at*
- [ double-free ] unless drop
+ [ drop ] [ double-free ] if
] when* ;
: malloc-exists? ( alien -- ? )
PRIVATE>
: malloc ( size -- alien )
- (malloc) check-ptr
- dup add-malloc ;
+ (malloc) check-ptr add-malloc ;
: calloc ( count size -- alien )
- (calloc) check-ptr
- dup add-malloc ;
+ (calloc) check-ptr add-malloc ;
: realloc ( alien size -- newalien )
+ [ >c-ptr ] dip
over malloc-exists? [ realloc-error ] unless
- dupd (realloc) check-ptr
- swap delete-malloc
- dup add-malloc ;
+ [ drop ] [ (realloc) check-ptr ] 2bi
+ [ delete-malloc ] [ add-malloc ] bi* ;
: free ( alien -- )
- [ delete-malloc ] [ (free) ] bi ;
+ >c-ptr [ delete-malloc ] [ (free) ] bi ;
: memcpy ( dst src size -- )
"void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ;
: strlen ( alien -- len )
"size_t" "libc" "strlen" { "char*" } alien-invoke ;
-<PRIVATE
-
-! Memory allocations
-TUPLE: memory-destructor alien disposed ;
-
-M: memory-destructor dispose* alien>> free ;
-
-PRIVATE>
-
-: &free ( alien -- alien )
- dup f memory-destructor boa &dispose drop ; inline
-
-: |free ( alien -- alien )
- dup f memory-destructor boa |dispose drop ; inline
+DESTRUCTOR: free
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! Portions copyright (C) 2007 Eduardo Cavazos.
! Portions copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
specialized-arrays.uint ;
IN: opengl
-: color>raw ( object -- r g b a )
- >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline
+: gl-color ( color -- ) >rgba-components glColor4d ; inline
-: gl-color ( color -- ) color>raw glColor4d ; inline
-
-: gl-clear-color ( color -- ) color>raw glClearColor ;
+: gl-clear-color ( color -- ) >rgba-components glClearColor ;
: gl-clear ( color -- )
gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
[ glDisableClientState ] each ; inline
MACRO: all-enabled ( seq quot -- )
- [ words>values ] dip [ (all-enabled) ] 2curry ;
+ [ words>values ] dip '[ _ _ (all-enabled) ] ;
MACRO: all-enabled-client-state ( seq quot -- )
- [ words>values ] dip [ (all-enabled-client-state) ] 2curry ;
+ [ words>values ] dip '[ _ (all-enabled-client-state) ] ;
: do-matrix ( mode quot -- )
swap [ glMatrixMode glPushMatrix call ] keep
glMatrixMode glPopMatrix ; inline
: gl-material ( face pname params -- )
- float-array{ } like underlying>> glMaterialfv ;
+ float-array{ } like glMaterialfv ;
: gl-vertex-pointer ( seq -- )
- [ 2 GL_FLOAT 0 ] dip underlying>> glVertexPointer ; inline
+ [ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline
: gl-color-pointer ( seq -- )
- [ 4 GL_FLOAT 0 ] dip underlying>> glColorPointer ; inline
+ [ 4 GL_FLOAT 0 ] dip glColorPointer ; inline
: gl-texture-coord-pointer ( seq -- )
- [ 2 GL_FLOAT 0 ] dip underlying>> glTexCoordPointer ; inline
+ [ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline
: line-vertices ( a b -- )
[ first2 [ 0.5 + ] bi@ ] bi@ 4 float-array{ } nsequence
glActiveTexture swap glBindTexture gl-error ;
: (set-draw-buffers) ( buffers -- )
- [ length ] [ >uint-array underlying>> ] bi glDrawBuffers ;
+ [ length ] [ >uint-array ] bi glDrawBuffers ;
MACRO: set-draw-buffers ( buffers -- )
- words>values [ (set-draw-buffers) ] curry ;
+ words>values '[ _ (set-draw-buffers) ] ;
: do-attribs ( bits quot -- )
swap glPushAttrib call glPopAttrib ; inline
: gl-look-at ( eye focus up -- )
[ first3 ] tri@ gluLookAt ;
-TUPLE: sprite loc dim dim2 dlist texture ;
-
-: <sprite> ( loc dim dim2 -- sprite )
- f f sprite boa ;
-
-: sprite-size2 ( sprite -- w h ) dim2>> first2 ;
-
-: sprite-width ( sprite -- w ) dim>> first ;
-
-: gray-texture ( sprite pixmap -- id )
+:: make-texture ( dim pixmap format type -- id )
gen-texture [
GL_TEXTURE_BIT [
GL_TEXTURE_2D swap glBindTexture
- [
- [ GL_TEXTURE_2D 0 GL_RGBA ] dip
- sprite-size2 0 GL_LUMINANCE_ALPHA
- GL_UNSIGNED_BYTE
- ] dip glTexImage2D
+ GL_TEXTURE_2D
+ 0
+ GL_RGBA
+ dim first2
+ 0
+ format
+ type
+ pixmap
+ glTexImage2D
] do-attribs
] keep ;
-
+
: gen-dlist ( -- id ) 1 glGenLists ;
: make-dlist ( type quot -- id )
- gen-dlist [ rot glNewList call glEndList ] keep ; inline
+ [ gen-dlist ] 2dip '[ _ glNewList @ glEndList ] keep ; inline
: init-texture ( -- )
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
: rect-texture-coords ( -- )
float-array{ 0 0 1 0 1 1 0 1 } gl-texture-coord-pointer ;
-: draw-sprite ( sprite -- )
- GL_TEXTURE_COORD_ARRAY [
- dup loc>> gl-translate
- GL_TEXTURE_2D over texture>> glBindTexture
- init-texture rect-texture-coords
- dim2>> fill-rect-vertices
- (gl-fill-rect)
- GL_TEXTURE_2D 0 glBindTexture
- ] do-enabled-client-state ;
-
-: make-sprite-dlist ( sprite -- id )
- GL_MODELVIEW [
- GL_COMPILE [ draw-sprite ] make-dlist
- ] do-matrix ;
-
-: init-sprite ( texture sprite -- )
- swap >>texture
- dup make-sprite-dlist >>dlist drop ;
-
: delete-dlist ( id -- ) 1 glDeleteLists ;
-: free-sprite ( sprite -- )
- [ dlist>> delete-dlist ]
- [ texture>> delete-texture ] bi ;
-
-: free-sprites ( sprites -- )
- [ nip [ free-sprite ] when* ] assoc-each ;
-
: with-translation ( loc quot -- )
GL_MODELVIEW [ [ gl-translate ] dip call ] do-matrix ; inline
GL_PROJECTION glMatrixMode
glLoadIdentity
GL_MODELVIEW glMatrixMode
- glLoadIdentity ;
+ glLoadIdentity ;
if ;
: (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s )
- [ '[ _ '[ @ com-unwrap ] [ swap 2array ] curry map ] ]
- [ '[ _ [ swap 2array ] curry map ] ] bi bi*
- swap append ;
+ [ '[ @ com-unwrap ] [ swap 2array ] curry map ]
+ [ [ swap 2array ] curry map ] bi-curry bi*
+ prepend ;
: compile-alien-callback ( word return parameters abi quot -- word )
'[ _ _ _ _ alien-callback ]
[ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ;
: (callbacks>vtbl) ( callbacks -- vtbl )
- [ execute ] void*-array{ } map-as underlying>> malloc-byte-array ;
+ [ execute ] void*-array{ } map-as malloc-byte-array ;
: (callbacks>vtbls) ( callbacks -- vtbls )
[ (callbacks>vtbl) ] map ;
USING: accessors assocs combinators continuations fry generalizations
io.pathnames kernel macros sequences stack-checker tools.test xml
- xml.utilities xml.writer arrays xml.data ;
+ xml.traversal xml.writer arrays xml.data ;
IN: xml.tests.suite
TUPLE: xml-test id uri sections description type ;
infer in>> '[ _ ndrop ] ;
: fails? ( quot -- ? )
- [ '[ _ drop-output f ] ]
- [ '[ drop _ drop-input t ] ] bi recover ; inline
+ [ drop-output f ] [ nip drop-input t ] bi-curry recover ; inline
: well-formed? ( uri -- answer )
[ file>xml ] fails? "not-wf" "valid" ? ;
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: xml.data xml.writer tools.test fry xml kernel multiline
- xml.writer.private io.streams.string xml.utilities sequences
+ xml.writer.private io.streams.string xml.traversal sequences
io.encodings.utf8 io.files accessors io.directories ;
IN: xml.writer.tests
[ "ns:foo" ] [ T{ name { space "ns" } { main "foo" } } name>string ] unit-test
: reprints-as ( to from -- )
- [ '[ _ ] ] [ '[ _ string>xml xml>string ] ] bi* unit-test ;
+ [ ] [ string>xml xml>string ] bi-curry* unit-test ;
: pprint-reprints-as ( to from -- )
- [ '[ _ ] ] [ '[ _ string>xml pprint-xml>string ] ] bi* unit-test ;
+ [ ] [ string>xml pprint-xml>string ] bi-curry* unit-test ;
: reprints-same ( string -- ) dup reprints-as ;
projects / factor.git / commitdiff