+++ /dev/null
-REQUIRES: contrib/slate ;
-USING: kernel io math alien namespaces sequences opengl slate ;
-IN: redbook-quadric
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (error-callback) ( GLenum -- )
-gluErrorString "Quadratic Error: " swap append print ;
-
-: error-callback ( -- alien )
-"void" { "GLenum" } [ (error-callback) ] alien-callback ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: start-list
-SYMBOL: qobj
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
-
-4 glGenLists start-list set
-start-list get [ start-list set ] curry add-dlist
-
-[
- gluNewQuadric qobj set
-
- qobj get GLU_ERROR error-callback gluQuadricCallback
-
- qobj get GLU_FILL gluQuadricDrawStyle
- qobj get GLU_SMOOTH gluQuadricNormals
- start-list get GL_COMPILE glNewList
- qobj get 0.75 15 10 gluSphere
- glEndList
-
- qobj get GLU_FILL gluQuadricDrawStyle
- qobj get GLU_FLAT gluQuadricNormals
- start-list get 1 + GL_COMPILE glNewList
- qobj get 0.5 0.3 1.0 15 5 gluCylinder
- glEndList
-
- qobj get GLU_LINE gluQuadricDrawStyle
- qobj get GLU_NONE gluQuadricNormals
- start-list get 2 + GL_COMPILE glNewList
- qobj get 0.25 1.0 20 4 gluDisk
- glEndList
-
- qobj get GLU_SILHOUETTE gluQuadricDrawStyle
- qobj get GLU_NONE gluQuadricNormals
- start-list get 3 + GL_COMPILE glNewList
- qobj get 0.0 1.0 20 4 0.0 225.0 gluPartialDisk
- glEndList
-] add-dlist ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: build-dlist ( -- )
-
-GL_FRONT GL_AMBIENT { 0.5 0.5 0.5 1.0 } gl-material-fv
-GL_FRONT GL_SPECULAR { 1.0 1.0 1.0 1.0 } gl-material-fv
-GL_FRONT GL_SHININESS { 50.0 } gl-material-fv
-
-GL_LIGHT0 GL_POSITION { 1.0 1.0 1.0 0.0 } gl-light-fv
-
-GL_LIGHT_MODEL_AMBIENT { 0.5 0.5 0.5 1.0 } gl-light-model-fv
-
-{ 0 0 0 0 } gl-clear-color
-
-GL_LIGHTING gl-enable
-GL_LIGHT0 gl-enable
-GL_DEPTH_TEST gl-enable
-
-GL_PROJECTION gl-matrix-mode gl-load-identity
--2.5 2.5 -2.5 2.5 -10.0 10.0 gl-ortho
-GL_MODELVIEW gl-matrix-mode gl-load-identity
-
-GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor gl-clear
-
-gl-push-matrix
-GL_LIGHTING gl-enable
-GL_SMOOTH gl-shade-model
-{ -1.0 -1.0 0.0 } gl-translate
-start-list get gl-call-list
-
-GL_FLAT gl-shade-model
-{ 0 2 0 } gl-translate
-gl-push-matrix
-300 { 1 0 0 } gl-rotate
-start-list get 1 + gl-call-list
-gl-pop-matrix
-
-GL_LIGHTING gl-disable
-{ 0.0 1.0 1.0 1.0 } gl-color
-{ 2.0 -2.0 0.0 } gl-translate
-start-list get 2 + gl-call-list
-
-{ 1 1 0 1 } gl-color
-{ 0 2 0 } gl-translate
-start-list get 3 + gl-call-list
-
-gl-pop-matrix ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: threads
-
-: go ( -- )
-slate-window
-init flush-dlist flush-slate 1000 sleep reset-slate
-build-dlist flush-dlist flush-slate ;
-
-! USE: redbook-examples-quadric
-! go
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2006 Eduardo Cavazos.
-
-REQUIRES: contrib/math contrib/alien contrib/vars ;
-
-USING: kernel namespaces math sequences vectors arrays opengl gadgets
- math-contrib alien-contrib vars ;
-
-IN: slate
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Slate gadget implementation
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: slate action ;
-
-C: slate ( -- <slate> ) dup delegate>gadget [ ] over set-slate-action ;
-
-M: slate pref-dim* ( <slate> -- ) drop { 100 100 0 } ;
-
-SYMBOL: self
-
-M: slate draw-gadget* ( <slate> -- ) dup self set slate-action call ;
-
-: get-action ( -- quot ) self get slate-action ;
-
-: set-action ( quot -- ) self get set-slate-action ;
-
-: action> get-action ;
-
-: >action set-action ;
-
-: flush-slate ( -- ) self get relayout-1 ;
-
-VAR: dlist
-
-SYMBOL: capacity
-
-: reset-dlist ( -- ) capacity get <vector> dlist set ;
-
-: add-dlist ( quot -- ) dlist get swap nappend ;
-
-: flush-dlist ( -- ) get-action dlist get append set-action reset-dlist ;
-
-: reset-slate ( -- ) [ ] set-action reset-dlist ;
-
-: new-slate ( -- )
-<slate> self set 100 capacity set reset-dlist self get ;
-
-: slate-window ( -- ) new-slate "Slate" open-titled-window ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Slate OpenGL commands
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: curry2 ( a b quot -- quot ) 2 [ curry ] times ;
-
-: curry3 ( a b c quot -- quot ) 3 [ curry ] times ;
-
-: curry4 ( a b c d quot -- quot ) 4 [ curry ] times ;
-
-: curry5 ( a b c d e quot -- quot ) 5 [ curry ] times ;
-
-: curry6 ( a b c d e f quot -- quot ) 6 [ curry ] times ;
-
-: curry9 ( a b c d e f g h i quot -- quot ) 9 [ curry ] times ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-clear-color ( vec -- ) first4 [ glClearColor ] curry4 add-dlist ;
-
-: gl-get-floatv ( pname params -- ) [ glGetFloatv ] curry2 add-dlist ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-clear ( mask -- ) [ glClear ] curry add-dlist ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-color ( vec -- ) first4 [ glColor4f ] curry4 add-dlist ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-ortho ( left right bottom top near far -- ) [ glOrtho ] curry6 add-dlist ;
-
-: gl-frustum ( left right bottom top near far -- ) [ glFrustum ] curry6 add-dlist ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-vertex2 ( vec -- ) first2 [ glVertex2f ] curry2 add-dlist ;
-
-: gl-vertex3 ( vec -- ) first3 [ glVertex3f ] curry3 add-dlist ;
-
-: gl-vertex4 ( vec -- ) first4 [ glVertex4f ] curry4 add-dlist ;
-
-: gl-vertex ( vec -- ) gl-vertex3 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-normal ( vec -- ) first3 [ glNormal3f ] curry3 add-dlist ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-begin ( mode -- ) [ glBegin ] curry add-dlist ;
-
-: gl-end ( -- ) [ glEnd ] add-dlist ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-load-identity ( -- ) [ glLoadIdentity ] add-dlist ;
-
-: gl-matrix-mode ( mode -- ) [ glMatrixMode ] curry add-dlist ;
-
-: gl-push-matrix ( -- ) [ glPushMatrix ] add-dlist ;
-
-: gl-pop-matrix ( -- ) [ glPopMatrix ] add-dlist ;
-
-: gl-rotate ( angle vec -- ) first3 [ glRotatef ] curry4 add-dlist ;
-
-: gl-scale ( vec -- ) first3 [ glScalef ] curry3 add-dlist ;
-
-: gl-translate ( vec -- ) first3 [ glTranslatef ] curry3 add-dlist ;
-
-: gl-load-matrix ( byte-array -- ) [ glLoadMatrixf ] curry add-dlist ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-enable ( cap -- ) [ glEnable ] curry add-dlist ;
-
-: gl-disable ( cap -- ) [ glDisable ] curry add-dlist ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-call-list ( list -- ) [ glCallList ] curry add-dlist ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-shade-model ( mode -- ) [ glShadeModel ] curry add-dlist ;
-
-: gl-light-fv ( light pname params -- )
->float-array [ glLightfv ] curry3 add-dlist ;
-
-: gl-light-model-fv ( pname params -- )
->float-array [ glLightModelfv ] curry2 add-dlist ;
-
-: gl-material-fv ( face pname params -- )
->float-array [ glMaterialfv ] curry3 add-dlist ;
-
-: gl-line-width ( width -- ) [ glLineWidth ] curry add-dlist ;
-
-: gl-polygon-mode ( face mode -- ) [ glPolygonMode ] curry2 add-dlist ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: glu-look-at ( position focus up -- )
-[ glLoadIdentity ] add-dlist
->r >r first3 r> first3 r> first3 [ gluLookAt ] curry9 add-dlist ;
-
-: glu-ortho-2d ( left right bottom top -- ) [ gluOrtho2D ] curry4 add-dlist ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: black ( -- color ) { 0 0 0 1 } ;
-
-: white ( -- color ) { 1 1 1 1 } ;
-
-: red ( -- color ) { 1 0 0 1 } ;
-
-: green ( -- color ) { 0 1 0 1 } ;
-
-: blue ( -- color ) { 0 0 1 1 } ;
-
-: yellow ( -- color ) { 1 1 0 1 } ;
-
-: set-color-alpha ( color alpha -- color ) swap 3 head swap add ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: draw-line ( a b --- ) GL_LINES gl-begin gl-vertex gl-vertex gl-end ;
-
-: draw-lines ( seq -- ) GL_LINES gl-begin [ gl-vertex ] each gl-end ;
-
-: draw-line-strip ( seq -- ) GL_LINE_STRIP gl-begin [ gl-vertex ] each gl-end ;
-
-: draw-line-loop ( seq -- ) GL_LINE_LOOP gl-begin [ gl-vertex ] each gl-end ;
-
-: draw-polygon ( seq -- ) GL_POLYGON gl-begin [ gl-vertex ] each gl-end ;
-
-: draw-circle ( -- )
-100 [ 100 / 360 * deg>rad dup cos swap sin 0 3array ] map draw-polygon ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Slate GLU commands
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: glu-new-quadric ( -- ) [ gluNewQuadric ] add-dlist ;
-
-: glu-disk ( qobj innner outer slices loops -- ) [ gluDisk ] curry5 add-dlist ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Slate 2d utilities
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-IN: slate-2d
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: qobj
-
-: slate-window ( -- )
-new-slate "Slate" open-titled-window gluNewQuadric >qobj ;
-
-: init-2d ( left right bottom top -- )
-GL_PROJECTION gl-matrix-mode gl-load-identity -1 1 gl-ortho
-GL_MODELVIEW gl-matrix-mode gl-load-identity ;
-
-: draw-point ( point -- ) GL_POINTS gl-begin gl-vertex2 gl-end ;
-
-: draw-line ( a b -- ) GL_LINES gl-begin gl-vertex2 gl-vertex2 gl-end ;
-
-: draw-line-strip ( seq -- )
-GL_LINE_STRIP gl-begin [ gl-vertex2 ] each gl-end ;
-
-: draw-circle ( -- ) qobj> 0 1 100 5 glu-disk ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set-coordinates ( left right bottom top -- )
-[ glLoadIdentity gluOrtho2D ] curry curry curry curry add-dlist ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Slate miscellaneous utilities
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-IN: slate-misc
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: rect-width ( <rect> -- width ) 0 swap rect-dim nth ;
-
-: rect-height ( <rect> -- height ) 1 swap rect-dim nth ;
-
-: window-width ( -- width ) self get rect-width ;
-
-: window-height ( -- height ) self get rect-height ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set-clear-color ( color -- ) [ first4 glClearColor ] curry add-dlist ;
-
-: clear-window ( -- ) [ GL_COLOR_BUFFER_BIT glClear ] add-dlist ;
-
-: set-color ( color -- ) [ first4 glColor4f ] curry add-dlist ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-PROVIDE: contrib/slate ;
\ No newline at end of file
projects / factor.git / commitdiff