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

Merge branch 'master' of git://repo.or.cz/factor/jcg 

Conflicts:

	basis/cocoa/messages/messages.factor
db4
Doug Coleman 2008-10-15 23:56:42 -05:00
parent 4b0b19e8e7 3399a579d0
commit 171c235c96
7 changed files with 141 additions and 77 deletions
basis
cocoa
ui/cocoa/views

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

@ -3,9 +3,8 @@
USING: accessors alien alien.c-types alien.strings arrays assocs
combinators compiler kernel math namespaces make parser
prettyprint prettyprint.sections quotations sequences strings
words cocoa.runtime io macros memoize debugger
io.encodings.ascii effects compiler.generator libc libc.private
parser lexer init core-foundation ;
words cocoa.runtime io macros memoize debugger fry
io.encodings.ascii effects compiler.generator libc libc.private ;
IN: cocoa.messages
: make-sender ( method function -- quot )
@ -108,22 +107,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 +143,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 +201,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

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
]
}

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 ;

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
]