+++ /dev/null
-! Copyright (C) 2008 Matthew Willis.
-! See http://factorcode.org/license.txt for BSD license.
-USING: sequences math kernel byte-arrays cairo.ffi cairo
-io.backend ui.gadgets accessors opengl.gl arrays fry
-classes ui.render namespaces destructors libc ;
-IN: cairo.gadgets
-
-<PRIVATE
-: width>stride ( width -- stride ) 4 * ;
-
-: image-dims ( gadget -- width height stride )
- dim>> first2 over width>stride ; inline
-: image-buffer ( width height stride -- alien )
- * nip malloc ; inline
-PRIVATE>
-
-GENERIC: render-cairo* ( gadget -- )
-
-: render-cairo ( gadget -- alien )
- [
- image-dims
- [ image-buffer dup CAIRO_FORMAT_ARGB32 ]
- [ cairo_image_surface_create_for_data ] 3bi
- ] [ '[ _ render-cairo* ] with-cairo-from-surface ] bi ;
-
-TUPLE: cairo-gadget < gadget ;
-
-: <cairo-gadget> ( dim -- gadget )
- cairo-gadget new
- swap >>dim ;
-
-M: cairo-gadget draw-gadget*
- [
- [ dim>> ] [ render-cairo &free ] bi
- origin get first2 glRasterPos2i
- 1.0 -1.0 glPixelZoom
- [ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip
- glDrawPixels
- ] with-destructors ;
-
-: copy-surface ( surface -- )
- cr swap 0 0 cairo_set_source_surface
- cr cairo_paint ;
+++ /dev/null
-UI gadget for rendering graphics with Cairo
[ words>values ] dip '[ _ _ (all-enabled) ] ;
MACRO: all-enabled-client-state ( seq quot -- )
- [ words>values ] dip '[ _ (all-enabled-client-state) ] ;
+ [ words>values ] dip '[ _ _ (all-enabled-client-state) ] ;
: do-matrix ( mode quot -- )
swap [ glMatrixMode glPushMatrix call ] keep
M: vocab-tag article-content
\ $tagged-vocabs swap name>> 2array ;
-M: vocab-tag article-parent drop "vocab-index" ;
+M: vocab-tag article-parent drop "vocab-tags" ;
M: vocab-tag summary article-title ;
M: vocab-author article-content
\ $authored-vocabs swap name>> 2array ;
-M: vocab-author article-parent drop "vocab-index" ;
+M: vocab-author article-parent drop "vocab-authors" ;
M: vocab-author summary article-title ;
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: ui.backend ui.gadgets
-ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces
-classes.tuple colors accessors ;
+USING: ui.backend ui.gadgets ui.gadgets.worlds ui.pens.solid opengl
+opengl.gl kernel namespaces classes.tuple colors colors.constants
+accessors ;
IN: ui.gadgets.canvas
TUPLE: canvas < gadget dlist ;
: new-canvas ( class -- canvas )
- new black <solid> >>interior ; inline
+ new COLOR: black <solid> >>interior ; inline
: delete-canvas-dlist ( canvas -- )
[ find-gl-context ]
[ 2nip ] [ drop make-canvas-dlist ] if ; inline
: draw-canvas ( canvas quot -- )
- origin get [
- cache-canvas-dlist glCallList
- ] with-translation ; inline
+ cache-canvas-dlist glCallList ; inline
M: canvas ungraft* delete-canvas-dlist ;
+USING: colors help.markup help.syntax ui.pens ;
IN: ui.pens.polygon
-USING: help.markup help.syntax ;
HELP: polygon
{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid filled polygon, respectively. Instances of " { $link polygon } " have two slots:"
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: ;
+USING: accessors colors help.markup help.syntax kernel opengl
+opengl.gl sequences specialized-arrays.float ui.pens ;
IN: ui.pens.polygon
! Polygon pen
+++ /dev/null
-Windows UI backend
+++ /dev/null
-X11 UI backend
+++ /dev/null
-! Copyright (C) 2005, 2008 Eduardo Cavazos and Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays ui ui.gadgets
-ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render
-ui.event-loop assocs kernel math namespaces opengl sequences
-strings x11.xlib x11.events x11.xim x11.glx x11.clipboard
-x11.constants x11.windows io.encodings.string io.encodings.ascii
-io.encodings.utf8 combinators combinators.short-circuit command-line
-math.vectors classes.tuple opengl.gl threads math.geometry.rect
-environment ascii ;
-IN: ui.x11
-
-SINGLETON: x11-ui-backend
-
-: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
-
-TUPLE: x11-handle-base glx ;
-TUPLE: x11-handle < x11-handle-base xic window ;
-TUPLE: x11-pixmap-handle < x11-handle-base pixmap glx-pixmap ;
-
-C: <x11-handle> x11-handle
-C: <x11-pixmap-handle> x11-pixmap-handle
-
-M: world expose-event nip relayout ;
-
-M: world configure-event
- over configured-loc >>window-loc
- swap configured-dim >>dim
- ! In case dimensions didn't change
- relayout-1 ;
-
-CONSTANT: modifiers
- {
- { S+ HEX: 1 }
- { C+ HEX: 4 }
- { A+ HEX: 8 }
- }
-
-CONSTANT: key-codes
- H{
- { HEX: FF08 "BACKSPACE" }
- { HEX: FF09 "TAB" }
- { HEX: FF0D "RET" }
- { HEX: FF8D "ENTER" }
- { HEX: FF1B "ESC" }
- { HEX: FFFF "DELETE" }
- { HEX: FF50 "HOME" }
- { HEX: FF51 "LEFT" }
- { HEX: FF52 "UP" }
- { HEX: FF53 "RIGHT" }
- { HEX: FF54 "DOWN" }
- { HEX: FF55 "PAGE_UP" }
- { HEX: FF56 "PAGE_DOWN" }
- { HEX: FF57 "END" }
- { HEX: FF58 "BEGIN" }
- { HEX: FFBE "F1" }
- { HEX: FFBF "F2" }
- { HEX: FFC0 "F3" }
- { HEX: FFC1 "F4" }
- { HEX: FFC2 "F5" }
- { HEX: FFC3 "F6" }
- { HEX: FFC4 "F7" }
- { HEX: FFC5 "F8" }
- { HEX: FFC6 "F9" }
- }
-
-: key-code ( keysym -- keycode action? )
- dup key-codes at [ t ] [ 1string f ] ?if ;
-
-: event-modifiers ( event -- seq )
- XKeyEvent-state modifiers modifier ;
-
-: valid-input? ( string gesture -- ? )
- over empty? [ 2drop f ] [
- mods>> { f { S+ } } member? [
- [ { [ 127 = not ] [ CHAR: \s >= ] } 1&& ] all?
- ] [
- [ { [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] } 1&& ] all?
- ] if
- ] if ;
-
-: key-down-event>gesture ( event world -- string gesture )
- dupd
- handle>> xic>> lookup-string
- [ swap event-modifiers ] dip key-code <key-down> ;
-
-M: world key-down-event
- [ key-down-event>gesture ] keep
- [ propagate-key-gesture drop ]
- [ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
- 3bi ;
-
-: key-up-event>gesture ( event -- gesture )
- dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
-
-M: world key-up-event
- [ key-up-event>gesture ] dip propagate-key-gesture ;
-
-: mouse-event>gesture ( event -- modifiers button loc )
- [ event-modifiers ]
- [ XButtonEvent-button ]
- [ mouse-event-loc ]
- tri ;
-
-M: world button-down-event
- [ mouse-event>gesture [ <button-down> ] dip ] dip
- send-button-down ;
-
-M: world button-up-event
- [ mouse-event>gesture [ <button-up> ] dip ] dip
- send-button-up ;
-
-: mouse-event>scroll-direction ( event -- pair )
- XButtonEvent-button {
- { 4 { 0 -1 } }
- { 5 { 0 1 } }
- { 6 { -1 0 } }
- { 7 { 1 0 } }
- } at ;
-
-M: world wheel-event
- [ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip
- send-wheel ;
-
-M: world enter-event motion-event ;
-
-M: world leave-event 2drop forget-rollover ;
-
-M: world motion-event
- [ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip
- move-hand fire-motion ;
-
-M: world focus-in-event
- nip
- dup handle>> xic>> XSetICFocus focus-world ;
-
-M: world focus-out-event
- nip
- dup handle>> xic>> XUnsetICFocus unfocus-world ;
-
-M: world selection-notify-event
- [ handle>> window>> selection-from-event ] keep
- user-input ;
-
-: supported-type? ( atom -- ? )
- { "UTF8_STRING" "STRING" "TEXT" }
- [ x-atom = ] with any? ;
-
-: clipboard-for-atom ( atom -- clipboard )
- {
- { XA_PRIMARY [ selection get ] }
- { XA_CLIPBOARD [ clipboard get ] }
- [ drop <clipboard> ]
- } case ;
-
-: encode-clipboard ( string type -- bytes )
- XSelectionRequestEvent-target
- XA_UTF8_STRING = utf8 ascii ? encode ;
-
-: set-selection-prop ( evt -- )
- dpy get swap
- [ XSelectionRequestEvent-requestor ] keep
- [ XSelectionRequestEvent-property ] keep
- [ XSelectionRequestEvent-target ] keep
- [ 8 PropModeReplace ] dip
- [
- XSelectionRequestEvent-selection
- clipboard-for-atom contents>>
- ] keep encode-clipboard dup length XChangeProperty drop ;
-
-M: world selection-request-event
- drop dup XSelectionRequestEvent-target {
- { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
- { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
- { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
- [ drop send-notify-failure ]
- } cond ;
-
-M: x11-ui-backend (close-window) ( handle -- )
- dup xic>> XDestroyIC
- dup glx>> destroy-glx
- window>> dup unregister-window
- destroy-window ;
-
-M: world client-event
- swap close-box? [ ungraft ] [ drop ] if ;
-
-: gadget-window ( world -- )
- dup window-loc>> over rect-dim glx-window
- over "Factor" create-xic rot <x11-handle>
- 2dup window>> register-window
- >>handle drop ;
-
-: wait-event ( -- event )
- QueuedAfterFlush events-queued 0 > [
- next-event dup
- None XFilterEvent zero? [ drop wait-event ] unless
- ] [
- ui-wait wait-event
- ] if ;
-
-M: x11-ui-backend do-events
- wait-event dup XAnyEvent-window window dup
- [ handle-event ] [ 2drop ] if ;
-
-: x-clipboard@ ( gadget clipboard -- prop win )
- atom>> swap
- find-world handle>> window>> ;
-
-M: x-clipboard copy-clipboard
- [ x-clipboard@ own-selection ] keep
- (>>contents) ;
-
-M: x-clipboard paste-clipboard
- [ find-world handle>> window>> ] dip atom>> convert-selection ;
-
-: init-clipboard ( -- )
- XA_PRIMARY <x-clipboard> selection set-global
- XA_CLIPBOARD <x-clipboard> clipboard set-global ;
-
-: set-title-old ( dpy window string -- )
- dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
-
-: set-title-new ( dpy window string -- )
- [ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
- utf8 encode dup length XChangeProperty drop ;
-
-M: x11-ui-backend set-title ( string world -- )
- handle>> window>> swap
- [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
-
-M: x11-ui-backend set-fullscreen* ( ? world -- )
- handle>> window>> "XClientMessageEvent" <c-object>
- tuck set-XClientMessageEvent-window
- swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
- over set-XClientMessageEvent-data0
- ClientMessage over set-XClientMessageEvent-type
- dpy get over set-XClientMessageEvent-display
- "_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
- 32 over set-XClientMessageEvent-format
- "_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
- [ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
-
-M: x11-ui-backend (open-window) ( world -- )
- dup gadget-window
- handle>> window>> dup set-closable map-window ;
-
-M: x11-ui-backend raise-window* ( world -- )
- handle>> [
- dpy get swap window>> XRaiseWindow drop
- ] when* ;
-
-M: x11-handle select-gl-context ( handle -- )
- dpy get swap
- [ window>> ] [ glx>> ] bi glXMakeCurrent
- [ "Failed to set current GLX context" throw ] unless ;
-
-M: x11-handle flush-gl-context ( handle -- )
- dpy get swap window>> glXSwapBuffers ;
-
-M: x11-pixmap-handle select-gl-context ( handle -- )
- dpy get swap
- [ glx-pixmap>> ] [ glx>> ] bi glXMakeCurrent
- [ "Failed to set current GLX context" throw ] unless ;
-
-M: x11-pixmap-handle flush-gl-context ( handle -- )
- drop ;
-
-M: x11-ui-backend (open-offscreen-buffer) ( world -- )
- dup dim>> glx-pixmap <x11-pixmap-handle> >>handle drop ;
-M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
- dpy get swap
- [ glx-pixmap>> glXDestroyGLXPixmap ]
- [ pixmap>> XFreePixmap drop ]
- [ glx>> glXDestroyContext ] 2tri ;
-
-M: x11-ui-backend offscreen-pixels ( world -- alien w h )
- [ [ dim>> ] [ handle>> pixmap>> ] bi pixmap-bits ] [ dim>> first2 ] bi ;
-
-M: x11-ui-backend ui ( -- )
- [
- f [
- [
- init-clipboard
- start-ui
- event-loop
- ] with-xim
- ] with-x
- ] ui-running ;
-
-M: x11-ui-backend beep ( -- )
- dpy get 100 XBell drop ;
-
-x11-ui-backend ui-backend set-global
-
-[ "DISPLAY" os-env "ui" "listener" ? ]
-main-vocab-hook set-global
+++ /dev/null
-
-USING: accessors arrays assocs calendar colors
-combinators.short-circuit help.markup help.syntax kernel locals
-math math.functions math.matrices math.order math.parser
-math.trig math.vectors opengl opengl.demo-support opengl.gl
-sbufs sequences strings threads ui.gadgets ui.gadgets.worlds
-ui.gestures ui.render ui.tools.workspace ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-IN: L-system
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <turtle> pos ori angle length thickness color vertices saved ;
-
-DEFER: default-L-parser-values
-
-: reset-turtle ( turtle -- turtle )
- { 0 0 0 } clone >>pos
- 3 identity-matrix >>ori
- V{ } clone >>vertices
- V{ } clone >>saved
-
- default-L-parser-values ;
-
-: turtle ( -- turtle ) <turtle> new reset-turtle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: step-turtle ( TURTLE LENGTH -- turtle )
-
- TURTLE
- TURTLE pos>> TURTLE ori>> { 0 0 LENGTH } m.v v+
- >>pos ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: Rx ( ANGLE -- Rx )
-
- [let | ANGLE [ ANGLE deg>rad ] |
-
- [let | A [ ANGLE cos ]
- B [ ANGLE sin neg ]
- C [ ANGLE sin ]
- D [ ANGLE cos ] |
-
- { { 1 0 0 }
- { 0 A B }
- { 0 C D } }
-
- ] ] ;
-
-:: Ry ( ANGLE -- Ry )
-
- [let | ANGLE [ ANGLE deg>rad ] |
-
- [let | A [ ANGLE cos ]
- B [ ANGLE sin ]
- C [ ANGLE sin neg ]
- D [ ANGLE cos ] |
-
- { { A 0 B }
- { 0 1 0 }
- { C 0 D } }
-
- ] ] ;
-
-:: Rz ( ANGLE -- Rz )
-
- [let | ANGLE [ ANGLE deg>rad ] |
-
- [let | A [ ANGLE cos ]
- B [ ANGLE sin neg ]
- C [ ANGLE sin ]
- D [ ANGLE cos ] |
-
- { { A B 0 }
- { C D 0 }
- { 0 0 1 } }
-
- ] ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: apply-rotation ( TURTLE ROTATION -- turtle )
-
- TURTLE TURTLE ori>> ROTATION m. >>ori ;
-
-: rotate-x ( turtle angle -- turtle ) Rx apply-rotation ;
-: rotate-y ( turtle angle -- turtle ) Ry apply-rotation ;
-: rotate-z ( turtle angle -- turtle ) Rz apply-rotation ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pitch-up ( turtle angle -- turtle ) neg rotate-x ;
-: pitch-down ( turtle angle -- turtle ) rotate-x ;
-
-: turn-left ( turtle angle -- turtle ) rotate-y ;
-: turn-right ( turtle angle -- turtle ) neg rotate-y ;
-
-: roll-left ( turtle angle -- turtle ) neg rotate-z ;
-: roll-right ( turtle angle -- turtle ) rotate-z ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: V ( -- V ) { 0 1 0 } ;
-
-: X ( turtle -- 3array ) ori>> [ first ] map ;
-: Y ( turtle -- 3array ) ori>> [ second ] map ;
-: Z ( turtle -- 3array ) ori>> [ third ] map ;
-
-: set-X ( turtle seq -- turtle ) over ori>> [ set-first ] 2each ;
-: set-Y ( turtle seq -- turtle ) over ori>> [ set-second ] 2each ;
-: set-Z ( turtle seq -- turtle ) over ori>> [ set-third ] 2each ;
-
-:: roll-until-horizontal ( TURTLE -- turtle )
-
- TURTLE
-
- V TURTLE Z cross normalize set-X
-
- TURTLE Z TURTLE X cross normalize set-Y ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: strafe-up ( TURTLE LENGTH -- turtle )
- TURTLE 90 pitch-up LENGTH step-turtle 90 pitch-down ;
-
-:: strafe-down ( TURTLE LENGTH -- turtle )
- TURTLE 90 pitch-down LENGTH step-turtle 90 pitch-up ;
-
-:: strafe-left ( TURTLE LENGTH -- turtle )
- TURTLE 90 turn-left LENGTH step-turtle 90 turn-right ;
-
-:: strafe-right ( TURTLE LENGTH -- turtle )
- TURTLE 90 turn-right LENGTH step-turtle 90 turn-left ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: polygon ( vertices -- ) GL_POLYGON glBegin [ first3 glVertex3d ] each glEnd ;
-
-: start-polygon ( turtle -- turtle ) dup vertices>> delete-all ;
-
-: finish-polygon ( turtle -- turtle ) dup vertices>> polygon ;
-
-: polygon-vertex ( turtle -- turtle ) dup [ pos>> ] [ vertices>> ] bi push ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: record-vertex ( turtle -- turtle ) dup pos>> first3 glVertex3d ;
-
-: draw-forward ( turtle length -- turtle )
- GL_LINES glBegin [ record-vertex ] dip step-turtle record-vertex glEnd ;
-
-: move-forward ( turtle length -- turtle ) step-turtle polygon-vertex ;
-
-: sneak-forward ( turtle length -- turtle ) step-turtle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: scale-length ( turtle m -- turtle ) over length>> * >>length ;
-: scale-angle ( turtle m -- turtle ) over angle>> * >>angle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set-thickness ( turtle i -- turtle ) dup glLineWidth >>thickness ;
-
-: scale-thickness ( turtle m -- turtle )
- over thickness>> * 0.5 max set-thickness ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: color-table ( -- colors )
- {
- T{ rgba f 0 0 0 1 } ! black
- T{ rgba f 0.5 0.5 0.5 1 } ! grey
- T{ rgba f 1 0 0 1 } ! red
- T{ rgba f 1 1 0 1 } ! yellow
- T{ rgba f 0 1 0 1 } ! green
- T{ rgba f 0.25 0.88 0.82 1 } ! turquoise
- T{ rgba f 0 0 1 1 } ! blue
- T{ rgba f 0.63 0.13 0.94 1 } ! purple
- T{ rgba f 0.00 0.50 0.00 1 } ! dark green
- T{ rgba f 0.00 0.82 0.82 1 } ! dark turquoise
- T{ rgba f 0.00 0.00 0.50 1 } ! dark blue
- T{ rgba f 0.58 0.00 0.82 1 } ! dark purple
- T{ rgba f 0.50 0.00 0.00 1 } ! dark red
- T{ rgba f 0.25 0.25 0.25 1 } ! dark grey
- T{ rgba f 0.75 0.75 0.75 1 } ! medium grey
- T{ rgba f 1 1 1 1 } ! white
- } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : material-color ( color -- )
-! GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ;
-
-: material-color ( color -- )
- GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot color>raw 4array gl-material ;
-
-: set-color ( turtle i -- turtle )
- dup color-table nth dup gl-color material-color >>color ;
-
-: inc-color ( turtle -- turtle ) dup color>> 1 + set-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: save-turtle ( turtle -- turtle ) dup clone over saved>> push ;
-
-: restore-turtle ( turtle -- turtle ) saved>> pop dup color>> set-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: default-L-parser-values ( turtle -- turtle )
- 1 >>length 45 >>angle 1 >>thickness 2 >>color ;
-
-: L-parser-dialect ( -- commands )
-
- {
- { "+" [ dup angle>> turn-left ] }
- { "-" [ dup angle>> turn-right ] }
- { "&" [ dup angle>> pitch-down ] }
- { "^" [ dup angle>> pitch-up ] }
- { "<" [ dup angle>> roll-left ] }
- { ">" [ dup angle>> roll-right ] }
-
- { "|" [ 180.0 rotate-y ] }
- { "%" [ 180.0 rotate-z ] }
- { "$" [ roll-until-horizontal ] }
-
- { "F" [ dup length>> draw-forward ] }
- { "Z" [ dup length>> 2 / draw-forward ] }
- { "f" [ dup length>> move-forward ] }
- { "z" [ dup length>> 2 / move-forward ] }
- { "g" [ dup length>> sneak-forward ] }
- { "." [ polygon-vertex ] }
-
- { "[" [ save-turtle ] }
- { "]" [ restore-turtle ] }
-
- { "{" [ start-polygon ] }
- { "}" [ finish-polygon ] }
-
- { "/" [ 1.1 scale-length ] } ! double quote command in lparser
- { "'" [ 0.9 scale-length ] }
- { ";" [ 1.1 scale-angle ] }
- { ":" [ 0.9 scale-angle ] }
- { "?" [ 1.4 scale-thickness ] }
- { "!" [ 0.7 scale-thickness ] }
-
- { "c" [ dup color>> 1 + color-table length mod set-color ] }
-
- }
- ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <L-system> < gadget
- camera display-list pedestal paused
- turtle-values
- commands axiom rules string ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: iterate-system ( GADGET -- ) GADGET pedestal>> 0.5 + GADGET (>>pedestal) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: start-rotation-thread ( GADGET -- )
- GADGET f >>paused drop
- [
- [
- GADGET paused>>
- [ f ]
- [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
- if
- ]
- loop
- ]
- in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: open-paren ( -- ch ) CHAR: ( ;
-: close-paren ( -- ch ) CHAR: ) ;
-
-: open-paren? ( obj -- ? ) open-paren = ;
-: close-paren? ( obj -- ? ) close-paren = ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: read-instruction ( STRING -- next rest )
-
- { [ STRING length 1 > ] [ STRING second open-paren? ] } 0&&
- [ STRING close-paren STRING index 1 + cut ]
- [ STRING 1 cut ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: iterate-string-loop ( STRING RULES ACCUM -- )
- STRING empty? not
- [
- STRING read-instruction
-
- [let | REST [ ] NEXT [ ] |
-
- NEXT 1 head RULES at NEXT or ACCUM push-all
-
- REST RULES ACCUM iterate-string-loop ]
- ]
- when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: iterate-string ( STRING RULES -- string )
-
- [let | ACCUM [ STRING length 10 * <sbuf> ] |
-
- STRING RULES ACCUM iterate-string-loop
-
- ACCUM >string ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: interpret-string ( STRING COMMANDS -- )
-
- STRING empty? not
- [
- STRING read-instruction
-
- [let | REST [ ] NEXT [ ] |
-
- [let | COMMAND [ NEXT 1 head COMMANDS at ] |
-
- COMMAND
- [
- NEXT length 1 =
- [ COMMAND call ]
- [
- NEXT 2 tail 1 head* string>number
- COMMAND 1 tail*
- call
- ]
- if
- ]
- when ]
-
- REST COMMANDS interpret-string ]
- ]
- when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: iterate-L-system-string ( L-SYSTEM -- )
- L-SYSTEM string>> L-SYSTEM axiom>> or
- L-SYSTEM rules>>
- iterate-string
- L-SYSTEM (>>string) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: do-camera-look-at ( CAMERA -- )
-
- [let | EYE [ CAMERA pos>> ]
- FOCUS [ CAMERA clone 1 step-turtle pos>> ]
- UP [ CAMERA clone 90 pitch-up 1 step-turtle pos>> CAMERA pos>> v- ]
- |
-
- EYE FOCUS UP gl-look-at ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: generate-display-list ( L-SYSTEM -- )
-
- L-SYSTEM find-gl-context
-
- L-SYSTEM display-list>> GL_COMPILE glNewList
-
- turtle
- L-SYSTEM turtle-values>> [ ] or call
- L-SYSTEM string>> L-SYSTEM axiom>> or
- L-SYSTEM commands>>
- interpret-string
- drop
-
- glEndList ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <L-system> draw-gadget* ( L-SYSTEM -- )
-
- black gl-clear
-
- GL_FLAT glShadeModel
-
- GL_PROJECTION glMatrixMode
- glLoadIdentity
- -1 1 -1 1 1.5 200 glFrustum
-
- GL_MODELVIEW glMatrixMode
-
- glLoadIdentity
-
- L-SYSTEM camera>> do-camera-look-at
-
- GL_FRONT_AND_BACK GL_LINE glPolygonMode
-
- ! draw axis
- white gl-color GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
-
- ! rotate pedestal
-
- L-SYSTEM pedestal>> 0 0 1 glRotated
-
- L-SYSTEM display-list>> glCallList ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <L-system> graft* ( L-SYSTEM -- )
-
- L-SYSTEM find-gl-context
-
- 1 glGenLists L-SYSTEM (>>display-list) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <L-system> pref-dim* ( L-SYSTEM -- dim ) { 400 400 } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: with-camera ( L-SYSTEM QUOT -- )
- L-SYSTEM camera>> QUOT call drop
- L-SYSTEM relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<L-system>
-H{
- { T{ key-down f f "LEFT" } [ [ 5 turn-left ] with-camera ] }
- { T{ key-down f f "RIGHT" } [ [ 5 turn-right ] with-camera ] }
- { T{ key-down f f "UP" } [ [ 5 pitch-down ] with-camera ] }
- { T{ key-down f f "DOWN" } [ [ 5 pitch-up ] with-camera ] }
-
- { T{ key-down f f "a" } [ [ 1 step-turtle ] with-camera ] }
- { T{ key-down f f "z" } [ [ -1 step-turtle ] with-camera ] }
-
- { T{ key-down f f "q" } [ [ 5 roll-left ] with-camera ] }
- { T{ key-down f f "w" } [ [ 5 roll-right ] with-camera ] }
-
- { T{ key-down f { A+ } "LEFT" } [ [ 1 strafe-left ] with-camera ] }
- { T{ key-down f { A+ } "RIGHT" } [ [ 1 strafe-right ] with-camera ] }
- { T{ key-down f { A+ } "UP" } [ [ 1 strafe-up ] with-camera ] }
- { T{ key-down f { A+ } "DOWN" } [ [ 1 strafe-down ] with-camera ] }
-
- { T{ key-down f f "r" } [ start-rotation-thread ] }
-
- {
- T{ key-down f f "x" }
- [
- dup iterate-L-system-string
- dup generate-display-list
- dup relayout-1
- drop
- ]
- }
-
- { T{ key-down f f "F1" } [ drop "L-system" help-window ] }
-
-}
-set-gestures
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: L-system ( -- L-system )
-
- <L-system> new-gadget
-
- 0 >>pedestal
-
- ! turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ;
-
- turtle 90 pitch-down -5 step-turtle 2 strafe-up >>camera
-
- dup start-rotation-thread
-
- ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "L-system" "L-system"
-
-"Press 'x' to iterate the L-system." $nl
-
-"Camera control:"
-
-{ $table
-
- { "a" "Forward" }
- { "z" "Backward" }
-
- { "LEFT" "Turn left" }
- { "RIGHT" "Turn right" }
- { "UP" "Pitch down" }
- { "DOWN" "Pitch up" }
-
- { "q" "Roll left" }
- { "w" "Roll right" } } ;
-
-ABOUT: "L-system"
\ No newline at end of file
+++ /dev/null
-
-USING: accessors ui L-system ;
-
-IN: L-system.models.abop-1
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-1 ( <L-system> -- <L-system> )
-
- L-parser-dialect >>commands
-
- "c(12)FFAL" >>axiom
-
- {
- { "A" "F [ & '(.8) ! B L ] >(137) ' !(.9) A" }
- { "B" "F [ - '(.8) !(.9) $ C L ] ' !(.9) C" }
- { "C" "F [ + '(.8) !(.9) $ B L ] ' !(.9) B" }
-
- { "L" " ~ c(8) { +(30) f -(120) f -(120) f }" }
- }
- >>rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: main ( -- ) [ L-system abop-1 "L-system" open-window ] with-ui ;
-
-MAIN: main
+++ /dev/null
-
-USING: accessors ui L-system ;
-
-IN: L-system.models.abop-2
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-2 ( <L-system> -- <L-system> )
-
- L-parser-dialect >>commands
-
- [ 30 >>angle ] >>turtle-values
-
- "c(12)FAL" >>axiom
-
- {
- { "A" "F [&'(.7)!BL] >(137) [&'(.6)!BL] >(137) '(.9) !(.9) A" }
-
- { "B" "F [- '(.7) !(.9) $ C L] '(.9) !(.9) C" }
- { "C" "F [+ '(.7) !(.9) $ B L] '(.9) !(.9) B" }
-
- { "L" "~c(8){+f(.1)-f(.1)-f(.1)+|+f(.1)-f(.1)-f(.1)}" }
-
- } >>rules ;
-
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: main ( -- ) [ L-system abop-2 "L-system" open-window ] with-ui ;
-
-MAIN: main
+++ /dev/null
-
-USING: accessors ui L-system ;
-
-IN: L-system.models.abop-3
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-3 ( <L-system> -- <L-system> )
-
- L-parser-dialect >>commands
-
- [ 30 >>angle ] >>turtle-values
-
- "c(12)FA" >>axiom
-
- {
- { "A" "!(.9)t(.4)FB>(94)B>(132)B" }
- { "B" "[&t(.4)F$A]" }
- { "F" "'(1.25)F'(.8)" }
- }
- >>rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: main ( -- ) [ L-system abop-3 "L-system" open-window ] with-ui ;
-
-MAIN: main
+++ /dev/null
-
-USING: accessors ui L-system ;
-
-IN: L-system.models.abop-4
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-4 ( <L-system> -- <L-system> )
-
- L-parser-dialect >>commands
-
- [ 18 >>angle ] >>turtle-values
-
- "c(12)&(20)N" >>axiom
-
- {
- {
- "N"
- "FII[&(60)rY]>(90)[&(45)'(0.8)rA]>(90)[&(60)rY]>(90)[&(45)'(0.8)rD]!FIK"
- }
- { "Y" "[c(4){++l.--l.--l.++|++l.--l.--l.}]" }
- { "l" "g(.2)l" }
- { "K" "[!c(2)FF>w>(72)w>(72)w>(72)w>(72)w]" }
- { "w" "[c(2)^!F][c(5)&(72){-(54)f(3)+(54)f(3)|-(54)f(3)+(54)f(3)}]" }
- { "f" "_" }
-
- { "A" "B" }
- { "B" "C" }
- { "C" "D" }
- { "D" "E" }
- { "E" "G" }
- { "G" "H" }
- { "H" "N" }
-
- { "I" "FoO" }
- { "O" "FoP" }
- { "P" "FoQ" }
- { "Q" "FoR" }
- { "R" "FoS" }
- { "S" "FoT" }
- { "T" "FoU" }
- { "U" "FoV" }
- { "V" "FoW" }
- { "W" "FoX" }
- { "X" "_" }
-
- { "o" "$t(-0.03)" }
- { "r" "~(30)" }
- }
- >>rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: main ( -- ) [ L-system abop-4 "L-system" open-window ] with-ui ;
-
-MAIN: main
+++ /dev/null
-
-USING: accessors ui L-system ;
-
-IN: L-system.models.abop-5-angular
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-5-angular ( <L-system> -- <L-system> )
-
- L-parser-dialect >>commands
-
- "&(90)+(90)a" >>axiom
-
- {
- { "a" "F[+(45)l][-(45)l]^;ca" }
-
- { "l" "j" }
- { "j" "h" }
- { "h" "s" }
- { "s" "d" }
- { "d" "x" }
- { "x" "a" }
-
- { "F" "'(1.17)F'(.855)" }
- }
- >>rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: main ( -- ) [ L-system abop-5-angular "L-system" open-window ] with-ui ;
-
-MAIN: main
-
\ No newline at end of file
+++ /dev/null
-
-USING: accessors ui L-system ;
-
-IN: L-system.models.abop-5
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-5 ( <L-system> -- <L-system> )
-
- L-parser-dialect >>commands
-
- [ 5 >>angle ] >>turtle-values
-
- "a" >>axiom
-
- {
- { "a" "F[+(45)l][-(45)l]^;ca" }
-
- { "l" "j" }
- { "j" "h" }
- { "h" "s" }
- { "s" "d" }
- { "d" "x" }
- { "x" "a" }
-
- { "F" "'(1.17)F'(.855)" }
- }
- >>rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: main ( -- ) [ L-system abop-5 "L-system" open-window ] with-ui ;
-
-MAIN: main
-
\ No newline at end of file
+++ /dev/null
-
-USING: accessors ui L-system ;
-
-IN: L-system.models.abop-6
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: abop-6 ( <L-system> -- <L-system> )
-
- L-parser-dialect >>commands
-
- [ 5 >>angle ] >>turtle-values
-
- ! "&(90)+(90)FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x"
- "FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x"
- >>axiom
-
- {
- { "a" "F[cdx][cex]F!(.9)a" }
- { "x" "a" }
-
- { "d" "+d" }
- { "e" "-e" }
-
- { "F" "'(1.25)F'(.8)" }
- }
- >>rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: main ( -- ) [ L-system abop-6 "L-system" open-window ] with-ui ;
-
-MAIN: main
-
\ No newline at end of file
+++ /dev/null
-
-USING: accessors ui L-system ;
-
-IN: L-system.models.airhorse
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: airhorse ( <L-system> -- <L-system> )
-
- L-parser-dialect >>commands
-
- [ 10 >>angle ] >>turtle-values
-
- "C" >>axiom
-
- {
- { "C" "LBW" }
-
- { "B" "[[''aH]|[g]]" }
- { "a" "Fs+;'a" }
- { "g" "Ft+;'g" }
- { "s" "[::cc!!!!&&[FFcccZ]^^^^FFcccZ]" }
- { "t" "[c!!!!&[FF]^^FF]" }
-
- { "L" "O" }
- { "O" "P" }
- { "P" "Q" }
- { "Q" "R" }
- { "R" "U" }
- { "U" "X" }
- { "X" "Y" }
- { "Y" "V" }
- { "V" "[cc!!!&(90)[Zp]|[Zp]]" }
- { "p" "h>(120)h>(120)h" }
- { "h" "[+(40)!F'''p]" }
-
- { "H" "[cccci[>(50)dcFFF][<(50)ecFFF]]" }
- { "d" "Z!&Z!&:'d" }
- { "e" "Z!^Z!^:'e" }
- { "i" "-:/i" }
-
- { "W" "[%[!!cb][<<<!!cb][>>>!!cb]]" }
- { "b" "Fl!+Fl+;'b" }
- { "l" "[-cc{--z++z++z--|--z++z++z}]" }
- }
- >>rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: main ( -- ) [ L-system airhorse "L-system" open-window ] with-ui ;
-
-MAIN: main
-
\ No newline at end of file
+++ /dev/null
-
-USING: accessors ui L-system ;
-
-IN: L-system.models.tree-5
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: tree-5 ( <L-system> -- <L-system> )
-
- L-parser-dialect >>commands
-
- [ 5 >>angle ] >>turtle-values
-
- "c(4)FFS" >>axiom
-
- {
- { "S" "FFR>(60)R>(60)R>(60)R>(60)R>(60)R>(30)S" }
- { "R" "[Ba]" }
- { "a" "$tF[Cx]Fb" }
- { "b" "$tF[Dy]Fa" }
- { "B" "&B" }
- { "C" "+C" }
- { "D" "-D" }
-
- { "x" "a" }
- { "y" "b" }
-
- { "F" "'(1.25)F'(.8)" }
- }
- >>rules ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: main ( -- ) [ L-system tree-5 "L-system" open-window ] with-ui ;
-
-MAIN: main
-
\ No newline at end of file
! (c)2009 Joe Groff, Doug Coleman. see BSD license
USING: accessors combinators.short-circuit definitions functors
-kernel lexer namespaces parser prettyprint sequences words ;
+kernel lexer namespaces parser prettyprint tools.crossref
+sequences words ;
IN: annotations
<<
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel
- namespaces
- arrays
- accessors
- strings
- sequences
- locals
- threads
- math
- math.functions
- math.trig
- math.order
- math.ranges
- math.vectors
- random
- calendar
- opengl.gl
- opengl
- ui
- ui.gadgets
- ui.gadgets.tracks
- ui.gadgets.frames
- ui.gadgets.grids
- ui.render
- multi-methods
- multi-method-syntax
- combinators.short-circuit
- processing.shapes
- flatland ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-IN: boids
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: constrain ( n a b -- n ) rot min max ;
-
-: angle-between ( vec vec -- angle )
- [ v. ] [ [ norm ] bi@ * ] 2bi / -1 1 constrain acos rad>deg ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ;
-
-: relative-angle ( self other -- angle )
- over vel>> -rot relative-position angle-between ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: in-radius? ( self other radius -- ? ) [ distance ] dip <= ;
-: in-view? ( self other angle -- ? ) [ relative-angle ] dip 2 / <= ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: vsum ( vector-of-vectors -- vec ) { 0 0 } [ v+ ] reduce ;
-
-: vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ;
-
-: average-position ( boids -- pos ) [ pos>> ] map vaverage ;
-: average-velocity ( boids -- vel ) [ vel>> ] map vaverage ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <boid> < <vel> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <behaviour>
- { weight initial: 1.0 }
- { view-angle initial: 180 }
- { radius } ;
-
-TUPLE: <cohesion> < <behaviour> { radius initial: 75 } ;
-TUPLE: <alignment> < <behaviour> { radius initial: 50 } ;
-TUPLE: <separation> < <behaviour> { radius initial: 25 } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: within-neighborhood? ( SELF OTHER BEHAVIOUR -- ? )
-
- SELF OTHER
- {
- [ BEHAVIOUR radius>> in-radius? ]
- [ BEHAVIOUR view-angle>> in-view? ]
- [ eq? not ]
- }
- 2&& ;
-
-:: neighborhood ( SELF OTHERS BEHAVIOUR -- boids )
- OTHERS [| OTHER | SELF OTHER BEHAVIOUR within-neighborhood? ] filter ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: normalize* ( u -- v ) { 0.001 0.001 } v+ normalize ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: force* ( sequence <boid> <behaviour> -- force )
-
-:: cohesion-force ( OTHERS SELF BEHAVIOUR -- force )
- OTHERS average-position SELF pos>> v- normalize* BEHAVIOUR weight>> v*n ;
-
-:: alignment-force ( OTHERS SELF BEHAVIOUR -- force )
- OTHERS average-velocity normalize* BEHAVIOUR weight>> v*n ;
-
-:: separation-force ( OTHERS SELF BEHAVIOUR -- force )
- SELF pos>> OTHERS average-position v- normalize* BEHAVIOUR weight>> v*n ;
-
-METHOD: force* ( sequence <boid> <cohesion> -- force ) cohesion-force ;
-METHOD: force* ( sequence <boid> <alignment> -- force ) alignment-force ;
-METHOD: force* ( sequence <boid> <separation> -- force ) separation-force ;
-
-:: force ( OTHERS SELF BEHAVIOUR -- force )
- SELF OTHERS BEHAVIOUR neighborhood
- [ { 0 0 } ]
- [ SELF BEHAVIOUR force* ]
- if-empty ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: random-boids ( count -- boids )
- [
- drop
- <boid> new
- 2 [ drop 1000 random ] map >>pos
- 2 [ drop -10 10 [a,b] random ] map >>vel
- ]
- map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: draw-boid ( boid -- )
- glPushMatrix
- dup pos>> gl-translate-2d
- vel>> first2 rect> arg rad>deg 0 0 1 glRotated
- { { 0 5 } { 0 -5 } { 20 0 } } triangle
- fill-mode
- glPopMatrix ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gadget->sky ( gadget -- sky ) { 0 0 } swap dim>> <rectangle> boa ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: syntax ! Switch back to non-multi-method 'TUPLE:' syntax
-
-TUPLE: <boids-gadget> < gadget paused boids behaviours time-slice ;
-
-M: <boids-gadget> pref-dim* ( <boids-gadget> -- dim ) drop { 600 400 } ;
-M: <boids-gadget> ungraft* ( <boids-gadget> -- ) t >>paused drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: iterate-system ( BOIDS-GADGET -- )
-
- [let | SKY [ BOIDS-GADGET gadget->sky ]
- BOIDS [ BOIDS-GADGET boids>> ]
- TIME-SLICE [ BOIDS-GADGET time-slice>> ]
- BEHAVIOURS [ BOIDS-GADGET behaviours>> ] |
-
- BOIDS
-
- [| SELF |
-
- [wlet | force-due-to [| BEHAVIOUR | BOIDS SELF BEHAVIOUR force ] |
-
- ! F = m a. M is 1. So F = a.
-
- [let | ACCEL [ BEHAVIOURS [ force-due-to ] map vsum ] |
-
- [let | POS [ SELF pos>> SELF vel>> TIME-SLICE v*n v+ ]
- VEL [ SELF vel>> ACCEL TIME-SLICE v*n v+ ] |
-
- [let | POS [ POS SKY wrap ]
- VEL [ VEL normalize* ] |
-
- T{ <boid> f POS VEL } ] ] ] ]
-
- ]
-
- map
-
- BOIDS-GADGET (>>boids) ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <boids-gadget> draw-gadget* ( BOIDS-GADGET -- )
- origin get
- [ BOIDS-GADGET boids>> [ draw-boid ] each ]
- with-translation ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: start-boids-thread ( GADGET -- )
- GADGET f >>paused drop
- [
- [
- GADGET paused>>
- [ f ]
- [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
- if
- ]
- loop
- ]
- in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: default-behaviours ( -- seq )
- { <cohesion> <alignment> <separation> } [ new ] map ;
-
-: boids-gadget ( -- gadget )
- <boids-gadget> new-gadget
- 100 random-boids >>boids
- default-behaviours >>behaviours
- 10 >>time-slice
- t >>clipped? ;
-
-: run-boids ( -- ) boids-gadget dup "Boids" open-window start-boids-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: math.parser
- ui.gadgets.labels
- ui.gadgets.buttons
- ui.gadgets.packs ;
-
-: truncate-number ( n -- n ) 10 * round 10 / ;
-
-:: make-behaviour-control ( NAME BEHAVIOUR -- gadget )
- [let | NAME-LABEL [ NAME <label> reverse-video-theme ]
- VALUE-LABEL [ 20 32 <string> <label> reverse-video-theme ] |
-
- [wlet | update-value-label [ ! ( -- )
- BEHAVIOUR weight>> truncate-number number>string
- VALUE-LABEL
- (>>string) ] |
-
- update-value-label
-
- <pile> 1 >>fill
- { 1 0 } <track>
- NAME-LABEL 0.5 track-add
- VALUE-LABEL 0.5 track-add
- add-gadget
-
- "+0.1"
- [
- drop
- BEHAVIOUR [ 0.1 + ] change-weight drop
- update-value-label
- ]
- <bevel-button> add-gadget
-
- "-0.1"
- [
- drop
- BEHAVIOUR weight>> 0.1 >
- [
- BEHAVIOUR [ 0.1 - ] change-weight drop
- update-value-label
- ]
- when
- ]
- <bevel-button> add-gadget ] ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: make-population-control ( BOIDS-GADGET -- gadget )
- [let | VALUE-LABEL [ 20 32 <string> <label> reverse-video-theme ] |
-
- [wlet | update-value-label [ ( -- )
- BOIDS-GADGET boids>> length number>string
- VALUE-LABEL
- (>>string) ] |
-
- update-value-label
-
- <pile> 1 >>fill
-
- { 1 0 } <track>
- "Population: " <label> reverse-video-theme 0.5 track-add
- VALUE-LABEL 0.5 track-add
- add-gadget
-
- "Add 10"
- [
- drop
- BOIDS-GADGET
- BOIDS-GADGET boids>> 10 random-boids append
- >>boids
- drop
- update-value-label
- ]
- <bevel-button>
- add-gadget
-
- "Sub 10"
- [
- drop
- BOIDS-GADGET boids>> length 10 >
- [
- BOIDS-GADGET
- BOIDS-GADGET boids>> 10 tail
- >>boids
- drop
- update-value-label
- ]
- when
- ]
- <bevel-button>
- add-gadget ] ] ( gadget -- gadget ) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: pause-toggle ( BOIDS-GADGET -- )
- BOIDS-GADGET paused>>
- [ BOIDS-GADGET start-boids-thread ]
- [ BOIDS-GADGET t >>paused drop ]
- if ;
-
-:: randomize-boids ( BOIDS-GADGET -- )
- BOIDS-GADGET BOIDS-GADGET boids>> length random-boids >>boids drop ;
-
-: boids-app ( -- )
-
- [let | BOIDS-GADGET [ boids-gadget ] |
-
- <frame>
-
- <shelf>
-
- 1 >>fill
-
- "Pause" [ drop BOIDS-GADGET pause-toggle ] <bevel-button> add-gadget
-
- "Randomize"
- [ drop BOIDS-GADGET randomize-boids ] <bevel-button> add-gadget
-
- BOIDS-GADGET make-population-control add-gadget
-
- "Cohesion: " BOIDS-GADGET behaviours>> first make-behaviour-control
- "Alignment: " BOIDS-GADGET behaviours>> second make-behaviour-control
- "Separation: " BOIDS-GADGET behaviours>> third make-behaviour-control
-
- [ add-gadget ] tri@
-
- @top grid-add
-
- BOIDS-GADGET @center grid-add
-
- "Boids" open-window
-
- BOIDS-GADGET start-boids-thread ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: boids-main ( -- ) [ boids-app ] with-ui ;
-
-MAIN: boids-main
\ No newline at end of file
+++ /dev/null
-Artificial life program simulating simulating the flocking behaviour of birds
+++ /dev/null
-
-USING: kernel syntax accessors sequences
- arrays calendar
- combinators.cleave combinators.short-circuit
- locals math math.constants math.functions math.libm
- math.order math.points math.vectors
- namespaces random sequences threads ui ui.gadgets ui.gestures
- math.ranges
- colors
- colors.gray
- vars
- multi-methods
- multi-method-syntax
- processing.shapes
- frame-buffer ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-IN: bubble-chamber
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! This is a Factor implementation of an art piece by Jared Tarbell:
-!
-! http://complexification.net/gallery/machines/bubblechamber/
-!
-! Jared's version is written in Processing (Java)
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! processing
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
-
-: 1random ( b -- num ) 0 swap 2random ;
-
-: at-fraction ( seq fraction -- val ) over length 1- * swap nth ;
-
-: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
-
-: mouse ( -- point ) hand-loc get ;
-
-: mouse-x ( -- x ) mouse first ;
-: mouse-y ( -- y ) mouse second ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! bubble-chamber.particle
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: collide ( particle -- )
-GENERIC: move ( particle -- )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: particle
- bubble-chamber pos vel speed speed-d theta theta-d theta-dd myc mya ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: initialize-particle ( particle -- particle )
-
- 0 0 {2} >>pos
- 0 0 {2} >>vel
-
- 0 >>speed
- 0 >>speed-d
- 0 >>theta
- 0 >>theta-d
- 0 >>theta-dd
-
- 0 0 0 1 rgba boa >>myc
- 0 0 0 1 rgba boa >>mya ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: center ( particle -- point ) bubble-chamber>> size>> 2 v/n ;
-
-DEFER: collision-theta
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: theta-dd-small? ( par limit -- par ? ) [ dup theta-dd>> abs ] dip < ;
-
-: random-theta-dd ( par a b -- par ) 2random >>theta-dd ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: turn ( particle -- particle )
- dup
- [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
- >>vel ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ;
-: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
-: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ;
-: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: out-of-bounds? ( PARTICLE -- ? )
- [let | X [ PARTICLE pos>> first ]
- Y [ PARTICLE pos>> second ]
- WIDTH [ PARTICLE bubble-chamber>> size>> first ]
- HEIGHT [ PARTICLE bubble-chamber>> size>> second ] |
-
- [let | LEFT [ WIDTH neg ]
- RIGHT [ WIDTH 2 * ]
- BOTTOM [ HEIGHT neg ]
- TOP [ HEIGHT 2 * ] |
-
- { [ X LEFT < ] [ X RIGHT > ] [ Y BOTTOM < ] [ Y TOP > ] } 0|| ] ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! bubble-chamber.particle.axion
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <axion> < particle ;
-
-: axion ( -- <axion> ) <axion> new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide ( <axion> -- )
-
- dup center >>pos
- 2 pi * 1random >>theta
- 1.0 6.0 2random >>speed
- 0.998 1.000 2random >>speed-d
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
-
-! : axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} \ stroke-color set ;
-! : axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} \ stroke-color set ;
-
-: axion-white ( dy -- dy ) dup 1 swap dy>alpha gray boa \ stroke-color set ;
-: axion-black ( dy -- dy ) dup 0 swap dy>alpha gray boa \ stroke-color set ;
-
-: axion-point- ( particle dy -- particle ) [ dup pos>> ] dip v-y point ;
-: axion-point+ ( particle dy -- particle ) [ dup pos>> ] dip v+y point ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move ( <axion> -- )
-
- T{ gray f 0.06 0.59 } \ stroke-color set
- dup pos>> point
-
- 1 4 [a,b] [ axion-white axion-point- ] each
- 1 4 [a,b] [ axion-black axion-point+ ] each
-
- dup vel>> move-by
-
- turn
-
- step-theta
- step-theta-d
- step-speed-mul
-
- [ ] [ speed-d>> 0.9999 * ] bi >>speed-d
-
- 1000 random 996 >
- [
- dup speed>> neg >>speed
- dup speed-d>> neg 2 + >>speed-d
-
- 100 random 30 > [ collide ] [ drop ] if
- ]
- [ drop ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! bubble-chamber.particle.hadron
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <hadron> < particle ;
-
-: hadron ( -- <hadron> ) <hadron> new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide ( <hadron> -- )
-
- dup center >>pos
- 2 pi * 1random >>theta
- 0.5 3.5 2random >>speed
- 0.996 1.001 2random >>speed-d
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
-
- 0 1 0 1 rgba boa >>myc
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move ( <hadron> -- )
-
- T{ gray f 1 0.11 } \ stroke-color set dup pos>> 1 v-y point
- T{ gray f 0 0.11 } \ stroke-color set dup pos>> 1 v+y point
-
- dup vel>> move-by
-
- turn
-
- step-theta
- step-theta-d
- step-speed-mul
-
- 1000 random 997 >
- [
- 1.0 >>speed-d
- 0.00001 >>theta-dd
-
- 100 random 70 > [ dup collide ] when
- ]
- when
-
- dup out-of-bounds? [ collide ] [ drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! bubble-chamber.particle.muon.colors
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: good-colors ( -- seq )
- {
- T{ rgba f 0.23 0.14 0.17 1 }
- T{ rgba f 0.23 0.14 0.15 1 }
- T{ rgba f 0.21 0.14 0.15 1 }
- T{ rgba f 0.51 0.39 0.33 1 }
- T{ rgba f 0.49 0.33 0.20 1 }
- T{ rgba f 0.55 0.45 0.32 1 }
- T{ rgba f 0.69 0.63 0.51 1 }
- T{ rgba f 0.64 0.39 0.18 1 }
- T{ rgba f 0.73 0.42 0.20 1 }
- T{ rgba f 0.71 0.45 0.29 1 }
- T{ rgba f 0.79 0.45 0.22 1 }
- T{ rgba f 0.82 0.56 0.34 1 }
- T{ rgba f 0.88 0.72 0.49 1 }
- T{ rgba f 0.85 0.69 0.40 1 }
- T{ rgba f 0.96 0.92 0.75 1 }
- T{ rgba f 0.99 0.98 0.87 1 }
- T{ rgba f 0.85 0.82 0.69 1 }
- T{ rgba f 0.99 0.98 0.87 1 }
- T{ rgba f 0.82 0.82 0.79 1 }
- T{ rgba f 0.65 0.69 0.67 1 }
- T{ rgba f 0.53 0.60 0.55 1 }
- T{ rgba f 0.57 0.53 0.68 1 }
- T{ rgba f 0.47 0.42 0.56 1 }
- } ;
-
-: anti-colors ( -- seq ) good-colors <reversed> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
-
-: set-good-color ( particle -- particle )
- color-fraction dup 0 1 between?
- [ good-colors at-fraction-of >>myc ]
- [ drop ]
- if ;
-
-: set-anti-color ( particle -- particle )
- color-fraction dup 0 1 between?
- [ anti-colors at-fraction-of >>mya ]
- [ drop ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! bubble-chamber.particle.muon
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <muon> < particle ;
-
-: muon ( -- <muon> ) <muon> new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide ( <muon> -- )
-
- dup center >>pos
- 2 32 [a,b] random >>speed
- 0.0001 0.001 2random >>speed-d
-
- dup collision-theta -0.1 0.1 2random + >>theta
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] while
-
- set-good-color
- set-anti-color
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move ( <muon> -- )
-
- [let | MUON [ ] |
-
- [let | WIDTH [ MUON bubble-chamber>> size>> first ] |
-
- MUON
-
- dup myc>> 0.16 >>alpha \ stroke-color set
- dup pos>> point
-
- dup mya>> 0.16 >>alpha \ stroke-color set
- dup pos>> first2 [ WIDTH swap - ] dip 2array point
-
- dup
- [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
- move-by
-
- step-theta
- step-theta-d
- step-speed-sub
-
- dup out-of-bounds? [ collide ] [ drop ] if ] ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! bubble-chamber.particle.quark
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <quark> < particle ;
-
-: quark ( -- <quark> ) <quark> new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide ( <quark> -- )
-
- dup center >>pos
- dup collision-theta -0.11 0.11 2random + >>theta
- 0.5 3.0 2random >>speed
-
- 0.996 1.001 2random >>speed-d
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move ( <quark> -- )
-
- [let | QUARK [ ] |
-
- [let | WIDTH [ QUARK bubble-chamber>> size>> first ] |
-
- QUARK
-
- dup myc>> 0.13 >>alpha \ stroke-color set
- dup pos>> point
-
- dup pos>> first2 [ WIDTH swap - ] dip 2array point
-
- [ ] [ vel>> ] bi move-by
-
- turn
-
- step-theta
- step-theta-d
- step-speed-mul
-
- 1000 random 997 >
- [
- dup speed>> neg >>speed
- 2 over speed-d>> - >>speed-d
- ]
- when
-
- dup out-of-bounds? [ collide ] [ drop ] if ] ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: syntax ! Switch back to non-multi-method 'TUPLE:' syntax
-
-TUPLE: <bubble-chamber> < <frame-buffer>
- paused particles collision-theta size ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : randomize-collision-theta ( bubble-chamber -- bubble-chamber )
-! 0 2 pi * 0.001 <range> random >>collision-theta ;
-
-: randomize-collision-theta ( bubble-chamber -- bubble-chamber )
- pi neg pi 0.001 <range> random >>collision-theta ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: collision-theta ( particle -- theta ) bubble-chamber>> collision-theta>> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: <bubble-chamber> pref-dim* ( gadget -- dim ) size>> ;
-
-M: <bubble-chamber> ungraft* ( <bubble-chamber> -- ) t >>paused drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: iterate-particle ( particle -- ) move ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <bubble-chamber> update-frame-buffer ( BUBBLE-CHAMBER -- )
-
- BUBBLE-CHAMBER particles>> [ iterate-particle ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: iterate-system ( <bubble-chamber> -- ) drop ;
-
-:: start-bubble-chamber-thread ( GADGET -- )
- GADGET f >>paused drop
- [
- [
- GADGET paused>>
- [ f ]
- [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
- if
- ]
- loop
- ]
- in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bubble-chamber ( -- <bubble-chamber> )
- <bubble-chamber> new-gadget
- { 1000 1000 } >>size
- randomize-collision-theta ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bubble-chamber-window ( -- <bubble-chamber> )
- bubble-chamber
- dup start-bubble-chamber-thread
- dup "Bubble Chamber" open-window ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: add-particle ( BUBBLE-CHAMBER PARTICLE -- bubble-chamber )
-
- PARTICLE BUBBLE-CHAMBER >>bubble-chamber drop
-
- BUBBLE-CHAMBER BUBBLE-CHAMBER particles>> PARTICLE suffix >>particles ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: mouse->collision-theta ( BUBBLE-CHAMBER -- BUBBLE-CHAMBER )
- mouse
- BUBBLE-CHAMBER size>> 2 v/n
- v-
- first2
- fatan2
- BUBBLE-CHAMBER (>>collision-theta)
- BUBBLE-CHAMBER ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: mouse-pressed ( BUBBLE-CHAMBER -- )
-
- BUBBLE-CHAMBER mouse->collision-theta drop
-
- 11
- [
- BUBBLE-CHAMBER particles>> [ <hadron>? ] filter random [ collide ] when*
- BUBBLE-CHAMBER particles>> [ <quark>? ] filter random [ collide ] when*
- BUBBLE-CHAMBER particles>> [ <muon>? ] filter random [ collide ] when*
- ]
- times ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<bubble-chamber> H{ { T{ button-down } [ mouse-pressed ] } } set-gestures
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: collide-random-particle ( bubble-chamber -- bubble-chamber )
- dup particles>> random collide ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: big-bang ( bubble-chamber -- bubble-chamber )
- dup particles>> [ collide ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: collide-one-of-each ( bubble-chamber -- bubble-chamber )
- dup
- particles>>
- [ [ <muon>? ] filter random collide ]
- [ [ <quark>? ] filter random collide ]
- [ [ <hadron>? ] filter random collide ]
- tri ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Some initial configurations
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ten-hadrons ( -- )
- bubble-chamber-window
- 10 [ drop hadron add-particle ] each
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: original ( -- )
-
- bubble-chamber-window
-
- 1789 [ muon add-particle ] times
- 1300 [ quark add-particle ] times
- 1000 [ hadron add-particle ] times
- 111 [ axion add-particle ] times
-
- particles>>
- [ [ <muon>? ] filter random collide ]
- [ [ <quark>? ] filter random collide ]
- [ [ <hadron>? ] filter random collide ]
- tri ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: hadron-chamber ( -- )
- bubble-chamber-window
- 1000 [ hadron add-particle ] times
- big-bang
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: quark-chamber ( -- )
- bubble-chamber-window
- 100 [ quark add-particle ] times
- big-bang
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: small ( -- )
- <bubble-chamber> new-gadget
- { 200 200 } >>size
- randomize-collision-theta
- dup start-bubble-chamber-thread
- dup "Bubble Chamber" open-window
-
- 42 [ muon add-particle ] times
- 30 [ quark add-particle ] times
- 21 [ hadron add-particle ] times
- 7 [ axion add-particle ] times
-
- collide-one-of-each
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: medium ( -- )
- <bubble-chamber> new-gadget
- { 400 400 } >>size
- randomize-collision-theta
- dup start-bubble-chamber-thread
- dup "Bubble Chamber" open-window
-
- 100 [ muon add-particle ] times
- 81 [ quark add-particle ] times
- 60 [ hadron add-particle ] times
- 9 [ axion add-particle ] times
-
- collide-one-of-each
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: large ( -- )
- <bubble-chamber> new-gadget
- { 600 600 } >>size
- randomize-collision-theta
- dup start-bubble-chamber-thread
- dup "Bubble Chamber" open-window
-
- 550 [ muon add-particle ] times
- 339 [ quark add-particle ] times
- 100 [ hadron add-particle ] times
- 11 [ axion add-particle ] times
-
- collide-one-of-each
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Experimental
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: muon-chamber ( -- )
- bubble-chamber-window
- 1000 [ muon add-particle ] times
- dup particles>> [ collide randomize-collision-theta ] each
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: original-big-bang ( -- )
- bubble-chamber
- { 1000 1000 } >>size
- dup start-bubble-chamber-thread
- dup "Bubble Chamber" open-window
-
- 1789 [ muon add-particle ] times
- 1300 [ quark add-particle ] times
- 1000 [ hadron add-particle ] times
- 111 [ axion add-particle ] times
-
- big-bang
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: original-big-bang-variant ( -- )
- bubble-chamber-window
- 1789 [ muon add-particle ] times
- 1300 [ quark add-particle ] times
- 1000 [ hadron add-particle ] times
- 111 [ axion add-particle ] times
- dup particles>> [ collide randomize-collision-theta ] each
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: ui bubble-chamber ;
-
-IN: bubble-chamber.hadron-chamber
-
-: main ( -- ) [ hadron-chamber ] with-ui ;
-
-MAIN: main
\ No newline at end of file
+++ /dev/null
-
-USING: ui bubble-chamber ;
-
-IN: bubble-chamber.large
-
-: main ( -- ) [ large ] with-ui ;
-
-MAIN: main
\ No newline at end of file
+++ /dev/null
-
-USING: ui bubble-chamber ;
-
-IN: bubble-chamber.medium
-
-: main ( -- ) [ medium ] with-ui ;
-
-MAIN: main
\ No newline at end of file
+++ /dev/null
-
-USING: ui bubble-chamber ;
-
-IN: bubble-chamber.original
-
-: main ( -- ) [ original ] with-ui ;
-
-MAIN: main
\ No newline at end of file
+++ /dev/null
-
-USING: ui bubble-chamber ;
-
-IN: bubble-chamber.quark-chamber
-
-: main ( -- ) [ quark-chamber ] with-ui ;
-
-MAIN: main
\ No newline at end of file
+++ /dev/null
-
-USING: ui bubble-chamber ;
-
-IN: bubble-chamber.small
-
-: main ( -- ) [ small ] with-ui ;
-
-MAIN: main
\ No newline at end of file
+++ /dev/null
-
-USING: ui bubble-chamber ;
-
-IN: bubble-chamber.ten-hadrons
-
-: main ( -- ) [ ten-hadrons ] with-ui ;
-
-MAIN: main
\ No newline at end of file
USING: arrays bunny.model bunny.cel-shaded continuations
destructors kernel math multiline opengl opengl.shaders
-opengl.framebuffers opengl.gl opengl.demo-support fry
+opengl.framebuffers opengl.gl opengl.textures opengl.demo-support fry
opengl.capabilities sequences ui.gadgets combinators accessors
macros locals ;
IN: bunny.outlined
+++ /dev/null
-Sampo Vuori
+++ /dev/null
-! Cairo "Hello World" demo
-! Copyright (c) 2007 Sampo Vuori
-! License: http://factorcode.org/license.txt
-!
-! This example is an adaptation of the following cairo sample code:
-! http://cairographics.org/samples/text/
-
-
-USING: cairo.ffi math math.constants byte-arrays kernel ui
-ui.render combinators ui.gadgets opengl.gl accessors
-namespaces opengl ;
-
-IN: cairo-demo
-
-: make-image-array ( -- array )
- 384 256 4 * * <byte-array> ;
-
-: convert-array-to-surface ( array -- cairo_surface_t )
- CAIRO_FORMAT_ARGB32 384 256 over 4 *
- cairo_image_surface_create_for_data ;
-
-TUPLE: cairo-demo-gadget < gadget image-array cairo-t ;
-
-M: cairo-demo-gadget draw-gadget* ( gadget -- )
- origin get [
- 0 0 glRasterPos2i
- 1.0 -1.0 glPixelZoom
- [ 384 256 GL_RGBA GL_UNSIGNED_BYTE ] dip
- image-array>> glDrawPixels
- ] with-translation ;
-
-: create-surface ( gadget -- cairo_surface_t )
- make-image-array [ swap (>>image-array) ] keep
- convert-array-to-surface ;
-
-: init-cairo ( gadget -- cairo_t )
- create-surface cairo_create ;
-
-M: cairo-demo-gadget pref-dim* drop { 384 256 } ;
-
-ERROR: no-cairo-t ;
-
-<PRIVATE
-
-: draw-hello-world ( gadget -- )
- cairo-t>> [ no-cairo-t ] unless*
- {
- [
- "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
- cairo_select_font_face
- ]
- [ 90.0 cairo_set_font_size ]
- [ 10.0 135.0 cairo_move_to ]
- [ "Hello" cairo_show_text ]
- [ 70.0 165.0 cairo_move_to ]
- [ "World" cairo_text_path ]
- [ 0.5 0.5 1 cairo_set_source_rgb ]
- [ cairo_fill_preserve ]
- [ 0 0 0 cairo_set_source_rgb ]
- [ 2.56 cairo_set_line_width ]
- [ cairo_stroke ]
- [ 1 0.2 0.2 0.6 cairo_set_source_rgba ]
- [ 10.0 135.0 5.12 0 pi 2 * cairo_arc ]
- [ cairo_close_path ]
- [ 70.0 165.0 5.12 0 pi 2 * cairo_arc ]
- [ cairo_fill ]
- } cleave ;
-
-PRIVATE>
-
-M: cairo-demo-gadget graft* ( gadget -- )
- dup dup init-cairo swap (>>cairo-t) draw-hello-world ;
-
-M: cairo-demo-gadget ungraft* ( gadget -- )
- cairo-t>> cairo_destroy ;
-
-: <cairo-demo-gadget> ( -- gadget )
- cairo-demo-gadget new-gadget ;
-
-: run ( -- )
- [
- <cairo-demo-gadget> "Hello World from Factor!" open-window
- ] with-ui ;
-
-MAIN: run
+++ /dev/null
-! Copyright (C) 2008 Matthew Willis
-! See http://factorcode.org/license.txt for BSD license.
-!
-! these samples are a subset of the samples on
-! http://cairographics.org/samples/
-USING: cairo cairo.ffi locals math.constants math
-io.backend kernel alien.c-types libc namespaces
-cairo.gadgets ui.gadgets accessors specialized-arrays.double ;
-
-IN: cairo-samples
-
-TUPLE: arc-gadget < cairo-gadget ;
-M:: arc-gadget render-cairo* ( gadget -- )
- [let | xc [ 128.0 ]
- yc [ 128.0 ]
- radius [ 100.0 ]
- angle1 [ pi 1/4 * ]
- angle2 [ pi ] |
- cr 10.0 cairo_set_line_width
- cr xc yc radius angle1 angle2 cairo_arc
- cr cairo_stroke
-
- ! draw helping lines
- cr 1 0.2 0.2 0.6 cairo_set_source_rgba
- cr 6.0 cairo_set_line_width
-
- cr xc yc 10.0 0 2 pi * cairo_arc
- cr cairo_fill
-
- cr xc yc radius angle1 angle1 cairo_arc
- cr xc yc cairo_line_to
- cr xc yc radius angle2 angle2 cairo_arc
- cr xc yc cairo_line_to
- cr cairo_stroke
- ] ;
-
-TUPLE: clip-gadget < cairo-gadget ;
-M: clip-gadget render-cairo* ( gadget -- )
- drop
- cr 128 128 76.8 0 2 pi * cairo_arc
- cr cairo_clip
- cr cairo_new_path
-
- cr 0 0 256 256 cairo_rectangle
- cr cairo_fill
- cr 0 1 0 cairo_set_source_rgb
- cr 0 0 cairo_move_to
- cr 256 256 cairo_line_to
- cr 256 0 cairo_move_to
- cr 0 256 cairo_line_to
- cr 10 cairo_set_line_width
- cr cairo_stroke ;
-
-TUPLE: clip-image-gadget < cairo-gadget ;
-M:: clip-image-gadget render-cairo* ( gadget -- )
- [let* | png [ "resource:misc/icons/Factor_128x128.png"
- normalize-path cairo_image_surface_create_from_png ]
- w [ png cairo_image_surface_get_width ]
- h [ png cairo_image_surface_get_height ] |
- cr 128 128 76.8 0 2 pi * cairo_arc
- cr cairo_clip
- cr cairo_new_path
-
- cr 192.0 w / 192.0 h / cairo_scale
- cr png 32 32 cairo_set_source_surface
- cr cairo_paint
- png cairo_surface_destroy
- ] ;
-
-TUPLE: dash-gadget < cairo-gadget ;
-M:: dash-gadget render-cairo* ( gadget -- )
- [let | dashes [ double-array{ 50 10 10 10 } underlying>> ]
- ndash [ 4 ] |
- cr dashes ndash -50 cairo_set_dash
- cr 10 cairo_set_line_width
- cr 128.0 25.6 cairo_move_to
- cr 230.4 230.4 cairo_line_to
- cr -102.4 0 cairo_rel_line_to
- cr 51.2 230.4 51.2 128.0 128.0 128.0 cairo_curve_to
- cr cairo_stroke
- ] ;
-
-TUPLE: gradient-gadget < cairo-gadget ;
-M:: gradient-gadget render-cairo* ( gadget -- )
- [let | pat [ 0 0 0 256 cairo_pattern_create_linear ]
- radial [ 115.2 102.4 25.6 102.4 102.4 128.0
- cairo_pattern_create_radial ] |
- pat 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
- pat 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
- cr 0 0 256 256 cairo_rectangle
- cr pat cairo_set_source
- cr cairo_fill
- pat cairo_pattern_destroy
-
- radial 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
- radial 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
- cr radial cairo_set_source
- cr 128.0 128.0 76.8 0 2 pi * cairo_arc
- cr cairo_fill
- radial cairo_pattern_destroy
- ] ;
-
-TUPLE: text-gadget < cairo-gadget ;
-M: text-gadget render-cairo* ( gadget -- )
- drop
- cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
- cairo_select_font_face
- cr 50 cairo_set_font_size
- cr 10 135 cairo_move_to
- cr "Hello" cairo_show_text
-
- cr 70 165 cairo_move_to
- cr "factor" cairo_text_path
- cr 0.5 0.5 1 cairo_set_source_rgb
- cr cairo_fill_preserve
- cr 0 0 0 cairo_set_source_rgb
- cr 2.56 cairo_set_line_width
- cr cairo_stroke
-
- ! draw helping lines
- cr 1 0.2 0.2 0.6 cairo_set_source_rgba
- cr 10 135 5.12 0 2 pi * cairo_arc
- cr cairo_close_path
- cr 70 165 5.12 0 2 pi * cairo_arc
- cr cairo_fill ;
-
-TUPLE: utf8-gadget < cairo-gadget ;
-M: utf8-gadget render-cairo* ( gadget -- )
- drop
- cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
- cairo_select_font_face
- cr 50 cairo_set_font_size
- "cairo_text_extents_t" malloc-object
- cr "日本語" pick cairo_text_extents
- cr over
- [ cairo_text_extents_t-width 2 / ]
- [ cairo_text_extents_t-x_bearing ] bi +
- 128 swap - pick
- [ cairo_text_extents_t-height 2 / ]
- [ cairo_text_extents_t-y_bearing ] bi +
- 128 swap - cairo_move_to
- free
- cr "日本語" cairo_show_text
-
- cr 1 0.2 0.2 0.6 cairo_set_source_rgba
- cr 6 cairo_set_line_width
- cr 128 0 cairo_move_to
- cr 0 256 cairo_rel_line_to
- cr 0 128 cairo_move_to
- cr 256 0 cairo_rel_line_to
- cr cairo_stroke ;
-
- USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
- : samples ( -- )
- {
- arc-gadget clip-gadget clip-image-gadget dash-gadget
- gradient-gadget text-gadget utf8-gadget
- }
- [ new-gadget { 256 256 } >>dim gadget. ] each ;
-
- MAIN: samples
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel alien.c-types combinators namespaces make arrays
- sequences splitting
- math math.functions math.vectors math.trig
- opengl.gl opengl.glu opengl ui ui.gadgets.slate
- vars colors self self.slots
- random-weighted colors.hsv cfdg.gl accessors
- ui.gadgets.handler ui.gestures assocs ui.gadgets macros
- specialized-arrays.double ;
-
-QUALIFIED: syntax
-
-IN: cfdg
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SELF-SLOTS: hsva
-
-: clear-color ( color -- ) gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! if (adjustment < 0)
-! base + base * adjustment
-
-! if (adjustment > 0)
-! base + (1 - base) * adjustment
-
-: adjust ( val num -- val ) dup 0 > [ 1 pick - * + ] [ dupd * + ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: hue ( num -- ) hue-> + 360 mod ->hue ;
-
-: saturation ( num -- ) saturation-> swap adjust ->saturation ;
-: brightness ( num -- ) value-> swap adjust ->value ;
-: alpha ( num -- ) alpha-> swap adjust ->alpha ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: h ( num -- ) hue ;
-: sat ( num -- ) saturation ;
-: b ( num -- ) brightness ;
-: a ( num -- ) alpha ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: color-stack
-
-: init-color-stack ( -- ) V{ } clone >color-stack ;
-
-: push-color ( -- ) self> color-stack> push self> clone >self ;
-
-: pop-color ( -- ) color-stack> pop dup >self gl-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ;
-
-: double-nth* ( c-array indices -- seq )
- swap byte-array>double-array [ nth ] curry map ;
-
-: check-size ( modelview -- num ) { 0 1 4 5 } double-nth* [ abs ] map supremum ;
-
-VAR: threshold
-
-: iterate? ( -- ? ) get-modelview-matrix check-size threshold> > ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! cos 2a sin 2a 0 0
-! sin 2a -cos 2a 0 0
-! 0 0 1 0
-! 0 0 0 1
-
-! column major order
-
-: gl-flip ( angle -- ) deg>rad dup dup dup
- [ 2 * cos , 2 * sin , 0 , 0 ,
- 2 * sin , 2 * cos neg , 0 , 0 ,
- 0 , 0 , 1 , 0 ,
- 0 , 0 , 0 , 1 , ]
- double-array{ } make underlying>> glMultMatrixd ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: circle ( -- )
- self> gl-color
- gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ;
-
-: triangle ( -- )
- self> gl-color
- GL_POLYGON glBegin
- 0 0.577 glVertex2d
- 0.5 -0.289 glVertex2d
- -0.5 -0.289 glVertex2d
- glEnd ;
-
-: square ( -- )
- self> gl-color
- GL_POLYGON glBegin
- -0.5 0.5 glVertex2d
- 0.5 0.5 glVertex2d
- 0.5 -0.5 glVertex2d
- -0.5 -0.5 glVertex2d
- glEnd ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: size ( scale -- ) dup 1 glScaled ;
-
-: size* ( scale-x scale-y -- ) 1 glScaled ;
-
-: rotate ( angle -- ) 0 0 1 glRotated ;
-
-: x ( x -- ) 0 0 glTranslated ;
-
-: y ( y -- ) 0 swap 0 glTranslated ;
-
-: flip ( angle -- ) gl-flip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: s ( scale -- ) size ;
-: s* ( scale-x scale-y -- ) size* ;
-: r ( angle -- ) rotate ;
-: f ( angle -- ) flip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: do ( quot -- )
- push-modelview-matrix
- push-color
- call
- pop-modelview-matrix
- pop-color ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: recursive ( quot -- ) iterate? swap when ; inline
-
-: multi ( seq -- ) random-weighted* call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: [rules] ( seq -- quot )
- [ unclip swap [ [ do ] curry ] map concat 2array ] map
- [ call-random-weighted ] swap prefix
- [ when ] swap prefix
- [ iterate? ] swap append ;
-
-MACRO: rules ( seq -- quot ) [rules] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: [rule] ( seq -- quot )
- [ [ do ] swap prefix ] map concat
- [ when ] swap prefix
- [ iterate? ] prepend ;
-
-MACRO: rule ( seq -- quot ) [rule] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: background
-
-: set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ;
-
-: set-background ( -- )
- set-initial-background
- background> call
- self> clear-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: rewrite-closures ;
-
-VAR: viewport ! { left width bottom height }
-
-VAR: start-shape
-
-: set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: dlist
-
-! : build-model-dlist ( -- )
-! 1 glGenLists dlist set
-! dlist get GL_COMPILE_AND_EXECUTE glNewList
-! start-shape> call
-! glEndList ;
-
-: build-model-dlist ( -- )
- 1 glGenLists dlist set
- dlist get GL_COMPILE_AND_EXECUTE glNewList
-
- set-initial-color
-
- self> gl-color
-
- start-shape> call
-
- glEndList ;
-
-: display ( -- )
-
- GL_PROJECTION glMatrixMode
- glLoadIdentity
- viewport> first dup viewport> second +
- viewport> third dup viewport> fourth + gluOrtho2D
-
- GL_MODELVIEW glMatrixMode
- glLoadIdentity
-
- set-background
-
- GL_COLOR_BUFFER_BIT glClear
-
- init-modelview-matrix-stack
- init-color-stack
-
- dlist get not
- [ build-model-dlist ]
- [ dlist get glCallList ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: delete-dlist ( -- ) dlist get [ dlist get 1 glDeleteLists dlist off ] when ;
-
-: cfdg-window* ( -- slate )
- C[ display ] <slate>
- { 500 500 } >>pdim
- C[ delete-dlist ] >>ungraft
- dup "CFDG" open-window ;
-
-: cfdg-window ( -- slate ) [ cfdg-window* ] with-ui ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: the-slate
-
-: rebuild ( -- ) delete-dlist the-slate get relayout-1 ;
-
-: <cfdg-gadget> ( -- slate )
- C[ display ] <slate>
- dup the-slate set
- { 500 500 } >>pdim
- C[ dlist get [ dlist get 1 glDeleteLists ] when ] >>ungraft
- <handler>
- H{ } clone
- T{ key-down f f "ENTER" } C[ drop rebuild ] swap pick set-at
- T{ button-down } C[ drop rebuild ] swap pick set-at
- >>table ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: fry
-
-: cfdg-window. ( quot -- )
- '[ [ @ <cfdg-gadget> "CFDG" open-window ] with-scope ] with-ui ;
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel alien.c-types namespaces sequences opengl.gl ;
-
-IN: cfdg.gl
-
-: get-modelview-matrix ( -- alien )
- GL_MODELVIEW_MATRIX 16 "GLdouble" <c-array> tuck glGetDoublev ;
-
-SYMBOL: modelview-matrix-stack
-
-: init-modelview-matrix-stack ( -- ) V{ } clone modelview-matrix-stack set ;
-
-: push-modelview-matrix ( -- )
- get-modelview-matrix modelview-matrix-stack get push ;
-
-: pop-modelview-matrix ( -- ) modelview-matrix-stack get pop glLoadMatrixd ;
\ No newline at end of file
+++ /dev/null
-
-USING: kernel namespaces math random opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.aqua-star
-
-: tentacle ( -- )
-iterate? [
- { { 1 [ circle
- [ .23 y .99 s .002 b tentacle ] do ] }
- { 1 [ circle
- [ .17 y 2 r .99 s .002 b tentacle ] do ] }
- { 1 [ circle
- [ .12 y -2 r .99 s .001 b tentacle ] do ] } }
- call-random-weighted
-] when ;
-
-: anemone ( -- )
-iterate? [
- tentacle
- [ 10 x -11 r .995 s -.002 b anemone ] do
-] when ;
-
-: anemone-begin ( -- ) [ 196 hue 0.8324 sat 1 b anemone ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ -1 b ] >background
- { -60 140 -120 140 } >viewport
- 0.1 >threshold
- [ anemone-begin ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces sequences math
- opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.chiaroscuro
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: white
-
-: black ( -- )
- {
- { 60 [ 0.6 s circle ] [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] }
- { 1 [ white black ] }
- }
- rules ;
-
-: white ( -- )
- {
- { 60 [ 0.6 s circle ] [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] }
- { 1 [ black white ] }
- }
- rules ;
-
-: chiaroscuro ( -- ) { [ 0.5 b black ] } rule ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ -0.5 b ] >background
- { -3 6 -2 6 } >viewport
- 0.03 >threshold
- [ chiaroscuro ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: tools.deploy.config ;
-V{
- { deploy-ui? t }
- { deploy-io 1 }
- { deploy-reflection 2 }
- { deploy-compiler? t }
- { deploy-math? t }
- { deploy-word-props? f }
- { deploy-c-types? f }
- { "stop-after-last-window?" t }
- { "bundle-name" "cfdg.models.flower6.app" }
-}
+++ /dev/null
-
-USING: kernel namespaces sequences math
- opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.flower6
-
-: petal6 ( -- )
-iterate? [
- [ 1 0.001 s* square ] do
- [ -0.5 x 0.01 s -1 b circle ] do
- [ 0.5 x 120.21 r 0.996 s 0.5 x 0.005 b petal6 ] do
-] when ;
-
-: flower6 ( -- )
-12 [ [ [ 30 r ] times petal6 ] do ] each
-12 [ [ [ 30 r ] times 90 flip petal6 ] do ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ ] >background
- { -1 2 -1 2 } >viewport
- 0.01 >threshold
- [ flower6 ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
-
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.game1-turn6
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: f-triangles ( -- )
- {
- [ 0.1 x 0.1 y -0.33 alpha 20 hue 0.7 sat 0.80 b triangle ]
- [ 10 hue 0.9 sat 0.33 b triangle ]
- [ 0.9 s 10 hue 0.5 sat 1.00 b triangle ]
- [ 0.8 s 5 r f-triangles ]
- }
- rule ;
-
-: f-squares ( -- )
- {
- [ 0.1 x 0.1 y -0.33 alpha 250 hue 0.70 sat 0.80 b square ]
- [ 220 hue 0.90 sat 0.33 b square ]
- [ 0.9 s 220 hue 0.25 sat 1.00 b square ]
- [ 0.8 s 5 r f-squares ]
- }
- rule ;
-
-DEFER: start
-
-: spiral ( -- )
- {
- { 1 [ f-squares ]
- [ 0.5 x 0.5 y 45 r f-triangles ]
- [ 1 y 25 r 0.9 s spiral ] }
-
- { 0.022 [ 90 flip 50 hue start ] }
- }
- rules ;
-
-: start ( -- )
- [ spiral ] do
- [ 120 r spiral ] do
- [ 240 r spiral ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ 66 hue 0.4 sat 0.5 b ] >background
- { -5 10 -5 10 } >viewport
- 0.001 >threshold
- [ start ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.lesson
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: shapes ( -- )
-[ square ] do
-[ 0.3 b circle ] do
-[ 0.5 b triangle ] do
-[ 0.7 b 60 r triangle ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chapter-1 ( -- )
-[ 2 x 5 y 3 size square ] do
-[ 6 x 5 y 3 size circle ] do
-[ 4 x 2 y 3 size triangle ] do
-[ 1 y 3 size shapes ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: foursquare ( -- )
-[ 0 x 0 y 5 3 size* square ] do
-[ 0 x 5 y 2 4 size* square ] do
-[ 5 x 5 y 3 size square ] do
-[ 5 x 0 y 2 size square ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chapter-2 ( -- )
-[ square ] do
-[ 3 x 7 y square ] do
-[ 5 x 7 y 30 r square ] do
-[ 3 x 5 y 0.75 size square ] do
-[ 5 x 5 y 0.5 b square ] do
-[ 7 x 6 y 45 r 0.7 size 0.7 b square ] do
-[ 5 x 1 y 10 r 0.2 size foursquare ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: spiral ( -- )
-iterate? [
- [ 0.5 size circle ] do
- [ 0.2 y -3 r 0.995 size spiral ] do
-] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chapter-3 ( -- ) [ 0 x 3 y spiral ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: tree
-
-: branch-left ( -- )
-{ { 1 [ 20 r tree ] }
- { 1 [ 30 r tree ] }
- { 1 [ 40 r tree ] }
- { 1 [ ] } } random-weighted* do ;
-
-: branch-right ( -- )
-{ { 1 [ -20 r tree ] }
- { 1 [ -30 r tree ] }
- { 1 [ -40 r tree ] }
- { 1 [ ] } } random-weighted* do ;
-
-: branch ( -- ) branch-left branch-right ;
-
-: tree ( -- )
-iterate? [
- {
- { 20 [ [ 0.25 size circle ] do
- [ 0.1 y 0.97 size tree ] do ] }
- { 1.5 [ branch ] }
- } random-weighted* do
-] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chapter-4 ( -- )
-[ 1 x 0 y tree ] do
-[ 6 x 0 y tree ] do
-[ 1 x 4 y tree ] do
-[ 6 x 4 y tree ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: toc ( -- )
-[ 0 x 0 y chapter-1 ] do
-[ 10 x 0 y chapter-2 ] do
-[ 0 x -10 y chapter-3 ] do
-[ 10 x -10 y chapter-4 ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ ] >background
- { -5 25 -15 25 } >viewport
- 0.03 >threshold
- [ toc ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
-
+++ /dev/null
-
-USING: namespaces sequences math random-weighted cfdg ;
-
-IN: cfdg.models.rules08
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: insct ( -- )
- [ 1.5 5.5 size* -1 brightness triangle ] do
- 10
- [ [ [ 1 0.9 size* -0.15 y 0.05 brightness ] times 1 5 size* triangle ] do ]
- each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: line
-
-: ligne ( -- )
- {
- { 1 [ 4.5 y 1.15 0.8 size* -0.3 b line ] }
- { 0.5 [ ] }
- }
- rules ;
-
-: line ( -- ) { [ insct ligne ] } rule ;
-
-: sole ( -- )
- {
- { 1 [ 1 brightness 0.5 saturation ligne ] [ 140 r 1 hue sole ] }
- { 0.01 [ ] }
- }
- rules ;
-
-: centre ( -- ) { [ 1 b 5 s circle ] [ sole ] } rule ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ -1 b ] >background
- { -20 40 -20 40 } viewport set
- [ centre ] >start-shape
- 0.0001 >threshold ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: run
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.sierpinski
-
-: shape ( -- ) circle ;
-
-! : sierpinski ( -- )
-! iterate? [
-! shape
-! [ 0.6 s 5 r 0.2 b -1.5 y 0 x sierpinski ] do
-! [ 0.6 s 5 r -0.2 b 0.75 y -1.2990375 x sierpinski ] do
-! [ 0.6 s 5 r 0.75 y 1.2990375 x sierpinski ] do
-! ] when ;
-
-: sierpinski ( -- )
-iterate? [
- shape
- [ -1.5 y 0 x 0.6 s 5 r 0.2 b sierpinski ] do
- [ 0.75 y -1.2990375 x 0.6 s 5 r -0.2 b sierpinski ] do
- [ 0.75 y 1.2990375 x 0.6 s 5 r sierpinski ] do
-] when ;
-
-: top ( -- ) [ -13.5 r 0.5 b sierpinski ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ ] >background
- { -4 8 -4 8 } >viewport
- 0.01 >threshold
- [ top ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
- random-weighted cfdg ;
-
-IN: cfdg.models.snowflake
-
-: spike ( -- )
-iterate? [
- { { 1 [ square
- [ 0.95 y 0.97 s spike ] do ] }
- { 0.03 [ square
- [ 60 r spike ] do
- [ -60 r spike ] do
- [ 0.95 y 0.97 s spike ] do ] } }
- call-random-weighted
-] when ;
-
-: snowflake ( -- )
-spike
-[ 60 r spike ] do
-[ 120 r spike ] do
-[ 180 r spike ] do
-[ 240 r spike ] do
-[ 300 r spike ] do ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ ] >background
- { -40 80 -40 80 } >viewport
- 0.1 >threshold
- [ snowflake ] >start-shape ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-MAIN: run
-
+++ /dev/null
-
-USING: namespaces sequences math random-weighted cfdg ;
-
-IN: cfdg.models.spirales
-
-DEFER: line
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: block ( -- ) { [ circle ] [ 0.3 s 60 flip line ] } rule ;
-
-: a1 ( -- ) { [ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] [ block ] } rule ;
-
-: line ( -- ) -0.3 a { [ 0 r a1 ] [ 120 r a1 ] [ 240 r a1 ] } rule ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init ( -- )
- [ -1 b ] >background
- { -20 40 -20 40 } >viewport
- [ line ] >start-shape
- 0.04 >threshold ;
-
-: run ( -- ) [ init ] cfdg-window. ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: run
\ No newline at end of file
+++ /dev/null
-Implementation of: http://contextfreeart.org
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.parser models
models.arrow models.range models.product sequences ui
-ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
-ui.gadgets.sliders ui.render math.rectangles accessors
+ui.gadgets ui.gadgets.tracks ui.gadgets.labels ui.gadgets.packs
+ui.gadgets.sliders ui.pens.solid ui.render math.rectangles accessors
ui.gadgets.grids colors ;
IN: color-picker
TUPLE: color-preview < gadget ;
: <color-preview> ( model -- gadget )
- color-preview new-gadget
+ color-preview new
swap >>model
{ 100 100 } >>dim ;
bi ;
: <color-picker> ( -- gadget )
- <frame>
+ vertical <track>
{ 5 5 } >>gap
<color-sliders>
- [ @top grid-add ]
+ [ f track-add ]
[
- [ <color-model> <color-preview> @center grid-add ]
+ [ <color-model> <color-preview> 1 track-add ]
[
[ [ truncate number>string ] map " " join ]
<arrow> <label-control>
- @bottom grid-add
+ f track-add
] bi
] bi* ;
: demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ;
: <run-vocab-button> ( vocab-name -- button )
- dup '[ drop [ _ run ] call-listener ] <bevel-button> { 0 0 } >>align ;
+ dup '[ drop [ _ run ] call-listener ] <border-button> ;
: <demo-runner> ( -- gadget )
<pile> 1 >>fill demo-vocabs [ <run-vocab-button> add-gadget ] each ;
+++ /dev/null
-
-USING: accessors alien.c-types combinators grouping kernel
- locals math math.geometry.rect math.vectors opengl.gl sequences
- ui.gadgets ui.render ;
-
-IN: frame-buffer
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <frame-buffer> < gadget pixels last-dim ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: update-frame-buffer ( <frame-buffer> -- )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-frame-buffer-pixels ( frame-buffer -- )
- dup
- rect-dim product "uint[4]" <c-array>
- >>pixels
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: frame-buffer ( -- <frame-buffer> ) <frame-buffer> new-gadget ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: draw-pixels ( FRAME-BUFFER -- )
-
- FRAME-BUFFER rect-dim first2
- GL_RGBA
- GL_UNSIGNED_INT
- FRAME-BUFFER pixels>>
- glDrawPixels ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: read-pixels ( FRAME-BUFFER -- )
-
- 0
- 0
- FRAME-BUFFER rect-dim first2
- GL_RGBA
- GL_UNSIGNED_INT
- FRAME-BUFFER pixels>>
- glReadPixels ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: copy-row ( OLD NEW -- )
-
- [let | LEN [ OLD NEW min-length ] |
-
- OLD LEN head-slice 0 NEW copy ] ;
-
-: copy-pixels ( old-pixels old-width new-pixels new-width -- )
- [ 16 * <sliced-groups> ] 2bi@
- [ copy-row ] 2each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: update-last-dim ( frame-buffer -- ) dup rect-dim >>last-dim drop ;
-
-M:: <frame-buffer> layout* ( FRAME-BUFFER -- )
-
- {
- {
- [ FRAME-BUFFER last-dim>> f = ]
- [
- FRAME-BUFFER init-frame-buffer-pixels
-
- FRAME-BUFFER update-last-dim
- ]
- }
- {
- [ FRAME-BUFFER [ rect-dim ] [ last-dim>> ] bi = not ]
- [
- [let | OLD-PIXELS [ FRAME-BUFFER pixels>> ]
- OLD-WIDTH [ FRAME-BUFFER last-dim>> first ] |
-
- FRAME-BUFFER init-frame-buffer-pixels
-
- FRAME-BUFFER update-last-dim
-
- [let | NEW-PIXELS [ FRAME-BUFFER pixels>> ]
- NEW-WIDTH [ FRAME-BUFFER last-dim>> first ] |
-
- OLD-PIXELS OLD-WIDTH NEW-PIXELS NEW-WIDTH copy-pixels ] ]
- ]
- }
- { [ t ] [ ] }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <frame-buffer> draw-gadget* ( FRAME-BUFFER -- )
-
- FRAME-BUFFER rect-dim { 0 1 } v* first2 glRasterPos2i
-
- FRAME-BUFFER draw-pixels
-
- FRAME-BUFFER update-frame-buffer
-
- glFlush
-
- FRAME-BUFFER read-pixels ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
--- /dev/null
+IN: game-input.tests
+USING: game-input tools.test kernel system ;
+
+os windows? os macosx? or [
+ [ ] [ open-game-input ] unit-test
+ [ ] [ close-game-input ] unit-test
+] when
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: tools.deploy.config ;
-V{
- { deploy-ui? t }
- { deploy-io 1 }
- { deploy-reflection 1 }
- { deploy-compiler? t }
- { deploy-math? t }
- { deploy-word-props? f }
- { deploy-c-types? f }
- { "stop-after-last-window?" t }
- { deploy-name "Golden Section" }
-}
+++ /dev/null
-
-USING: kernel namespaces math math.constants math.functions math.order
- arrays sequences
- opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme
- ui.gadgets.cartesian colors accessors combinators.cleave
- processing.shapes ;
-
-IN: golden-section
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! omega(i) = 2*pi*i*(phi-1)
-
-! x(i) = 0.5*i*cos(omega(i))
-! y(i) = 0.5*i*sin(omega(i))
-
-! radius(i) = 10*sin((pi*i)/720)
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: omega ( i -- omega ) phi 1- * 2 * pi * ;
-
-: x ( i -- x ) [ omega cos ] [ 0.5 * ] bi * ;
-: y ( i -- y ) [ omega sin ] [ 0.5 * ] bi * ;
-
-: center ( i -- point ) { x y } 1arr ;
-
-: radius ( i -- radius ) pi * 720 / sin 10 * ;
-
-: color ( i -- i ) dup 360.0 / dup 0.25 1 rgba boa >fill-color ;
-
-: line-width ( i -- i ) dup radius 0.5 * 1 max glLineWidth ;
-
-: draw ( i -- ) [ center ] [ radius 1.5 * 2 * ] bi circle ;
-
-: dot ( i -- ) color line-width draw ;
-
-: golden-section ( -- ) 720 [ dot ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: <golden-section> ( -- gadget )
- <cartesian>
- { 600 600 } >>pdim
- { -400 400 } x-range
- { -400 400 } y-range
- [ golden-section ] >>action ;
-
-: golden-section-window ( -- )
- [ <golden-section> "Golden Section" open-window ] with-ui ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: golden-section-window
+++ /dev/null
-Golden section demo
image>> draw-image ;
: <image-gadget> ( image -- gadget )
- \ image-gadget new-gadget
+ \ image-gadget new
swap >>image ;
: image-window ( path -- gadget )
+++ /dev/null
-William Schlieper
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: kernel vocabs.loader sequences strings splitting words irc.messages ;\r
-\r
-IN: irc.ui.commandparser\r
-\r
-: command ( string string -- string command )\r
- [ "say" ] when-empty\r
- dup "irc.ui.commands" lookup\r
- [ nip ]\r
- [ " " append prepend "quote" "irc.ui.commands" lookup ] if* ;\r
-\r
-: parse-message ( string -- )\r
- "/" ?head [ " " split1 swap command ] [ "say" command ] if execute ;\r
+++ /dev/null
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: accessors kernel sequences arrays irc.client\r
- irc.messages irc.ui namespaces ;\r
-\r
-IN: irc.ui.commands\r
-\r
-: say ( string -- )\r
- irc-tab get\r
- [ window>> client>> profile>> nickname>> <own-message> print-irc ]\r
- [ chat>> speak ] 2bi ;\r
-\r
-: me ( string -- ) ! Placeholder until I make /me look different\r
- "ACTION " 1 prefix prepend 1 suffix say ;\r
-\r
-: join ( string -- )\r
- irc-tab get window>> join-channel ;\r
-\r
-: query ( string -- )\r
- irc-tab get window>> query-nick ;\r
-\r
-: whois ( string -- )\r
- "WHOIS" swap { } clone swap <irc-client-message>\r
- irc-tab get listener>> speak ;\r
-\r
-: quote ( string -- )\r
- drop ; ! THIS WILL CHANGE\r
+++ /dev/null
-! Default system ircui-rc file\r
-! Copy into .ircui-rc in your home directory and then change username and such\r
-! To find your home directory, type "home ." into a Factor listener\r
-\r
-USING: irc.client irc.ui ;\r
-\r
-"irc.freenode.org" 8001 "factor-irc" f ! server port nick password\r
-{ "#concatenative" "#terrorisland" } ! all the channels you want to autojoin\r
-server-open\r
+++ /dev/null
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: kernel io.files io.pathnames parser editors sequences ;\r
-\r
-IN: irc.ui.load\r
-\r
-: file-or ( path path -- path ) [ [ exists? ] keep ] dip ? ;\r
-\r
-: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;\r
-\r
-: system-ui-rc ( -- path ) "extra/irc/ui/ircui-rc" resource-path ;\r
-\r
-: ircui-rc ( -- path ) personal-ui-rc system-ui-rc file-or ;\r
-\r
-: run-ircui ( -- ) ircui-rc run-file ;\r
+++ /dev/null
-A simple IRC client
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: accessors kernel threads combinators concurrency.mailboxes\r
- sequences strings hashtables splitting fry assocs hashtables colors\r
- sorting unicode.collation math.order\r
- ui ui.gadgets ui.gadgets.panes ui.gadgets.editors\r
- ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures\r
- ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels\r
- io io.styles namespaces calendar calendar.format models continuations\r
- irc.client irc.client.private irc.messages\r
- irc.ui.commandparser irc.ui.load vocabs.loader classes prettyprint ;\r
-\r
-RENAME: join sequences => sjoin\r
-\r
-IN: irc.ui\r
-\r
-SYMBOL: chat\r
-\r
-SYMBOL: client\r
-\r
-TUPLE: ui-window < tabbed client ;\r
-\r
-M: ui-window ungraft*\r
- client>> terminate-irc ;\r
-\r
-TUPLE: irc-tab < frame chat client window ;\r
-\r
-: write-color ( str color -- )\r
- foreground associate format ;\r
-CONSTANT: dark-red T{ rgba f 0.5 0.0 0.0 1 }\r
-CONSTANT: dark-green T{ rgba f 0.0 0.5 0.0 1 }\r
-CONSTANT: dark-blue T{ rgba f 0.0 0.0 0.5 1 }\r
-\r
-: dot-or-parens ( string -- string )\r
- [ "." ]\r
- [ "(" prepend ")" append ] if-empty ;\r
-\r
-GENERIC: write-irc ( irc-message -- )\r
-\r
-M: ping write-irc\r
- drop "* Ping" blue write-color ;\r
-\r
-M: privmsg write-irc\r
- "<" dark-blue write-color\r
- [ irc-message-sender write ] keep\r
- "> " dark-blue write-color\r
- trailing>> write ;\r
-\r
-M: notice write-irc\r
- [ type>> dark-blue write-color ] keep\r
- ": " dark-blue write-color\r
- trailing>> write ;\r
-\r
-TUPLE: own-message message nick timestamp ;\r
-\r
-: <own-message> ( message nick -- own-message )\r
- now own-message boa ;\r
-\r
-M: own-message write-irc\r
- "<" dark-blue write-color\r
- [ nick>> bold font-style associate format ] keep\r
- "> " dark-blue write-color\r
- message>> write ;\r
-\r
-M: join write-irc\r
- "* " dark-green write-color\r
- irc-message-sender write\r
- " has entered the channel." dark-green write-color ;\r
-\r
-M: part write-irc\r
- "* " dark-red write-color\r
- [ irc-message-sender write ] keep\r
- " has left the channel" dark-red write-color\r
- trailing>> dot-or-parens dark-red write-color ;\r
-\r
-M: quit write-irc\r
- "* " dark-red write-color\r
- [ irc-message-sender write ] keep\r
- " has left IRC" dark-red write-color\r
- trailing>> dot-or-parens dark-red write-color ;\r
-\r
-M: kick write-irc\r
- "* " dark-red write-color\r
- [ irc-message-sender write ] keep\r
- " has kicked " dark-red write-color\r
- [ who>> write ] keep\r
- " from the channel" dark-red write-color\r
- trailing>> dot-or-parens dark-red write-color ;\r
-\r
-M: mode write-irc\r
- "* " dark-blue write-color\r
- [ name>> write ] keep\r
- " has applied mode " dark-blue write-color\r
- [ mode>> write ] keep\r
- " to " dark-blue write-color\r
- parameter>> write ;\r
-\r
-M: nick write-irc\r
- "* " dark-blue write-color\r
- [ irc-message-sender write ] keep\r
- " is now known as " blue write-color\r
- trailing>> write ;\r
-\r
-M: unhandled write-irc\r
- "UNHANDLED: " write\r
- line>> dark-blue write-color ;\r
-\r
-M: irc-end write-irc\r
- drop "* You have left IRC" dark-red write-color ;\r
-\r
-M: irc-disconnected write-irc\r
- drop "* Disconnected" dark-red write-color ;\r
-\r
-M: irc-connected write-irc\r
- drop "* Connected" dark-green write-color ;\r
-\r
-M: irc-chat-end write-irc\r
- drop ;\r
-\r
-M: irc-message write-irc\r
- "UNIMPLEMENTED" write\r
- [ class pprint ] keep\r
- ": " write\r
- line>> dark-blue write-color ;\r
-\r
-GENERIC: time-happened ( message -- timestamp )\r
-\r
-M: irc-message time-happened timestamp>> ;\r
-\r
-M: object time-happened drop now ;\r
-\r
-: print-irc ( irc-message -- )\r
- [ time-happened timestamp>hms write " " write ]\r
- [ write-irc nl ] bi ;\r
-\r
-: send-message ( message -- )\r
- [ print-irc ]\r
- [ chat get speak ] bi ;\r
-\r
-GENERIC: handle-inbox ( tab message -- )\r
-\r
-: value-labels ( assoc val -- seq )\r
- '[ nip _ = ] assoc-filter keys sort-strings [ <label> ] map ;\r
-\r
-: add-gadget-color ( pack seq color -- pack )\r
- '[ _ >>color add-gadget ] each ;\r
-\r
-M: object handle-inbox\r
- nip print-irc ;\r
-\r
-: display ( stream tab -- )\r
- '[ _ [ [ t ]\r
- [ _ dup chat>> hear handle-inbox ]\r
- while ] with-output-stream ] "ircv" spawn drop ;\r
-\r
-: <irc-pane> ( tab -- tab pane )\r
- <scrolling-pane>\r
- [ <pane-stream> swap display ] 2keep ;\r
-\r
-TUPLE: irc-editor < editor outstream tab ;\r
-\r
-: <irc-editor> ( tab pane -- tab editor )\r
- irc-editor new-editor\r
- swap <pane-stream> >>outstream ;\r
-\r
-: editor-send ( irc-editor -- )\r
- { [ outstream>> ]\r
- [ [ irc-tab? ] find-parent ]\r
- [ editor-string ]\r
- [ "" swap set-editor-string ] } cleave\r
- '[ _ irc-tab set _ parse-message ] with-output-stream ;\r
-\r
-irc-editor "general" f {\r
- { T{ key-down f f "RET" } editor-send }\r
- { T{ key-down f f "ENTER" } editor-send }\r
-} define-command-map\r
-\r
-: new-irc-tab ( chat ui-window class -- irc-tab )\r
- new-frame\r
- swap >>window\r
- swap >>chat\r
- <irc-pane> [ <scroller> @center grid-add ] keep\r
- <irc-editor> <scroller> @bottom grid-add ;\r
-\r
-M: irc-tab graft*\r
- [ chat>> ] [ window>> client>> ] bi attach-chat ;\r
-\r
-M: irc-tab ungraft*\r
- chat>> detach-chat ;\r
-\r
-TUPLE: irc-channel-tab < irc-tab userlist ;\r
-\r
-: <irc-channel-tab> ( chat ui-window -- irc-tab )\r
- irc-channel-tab new-irc-tab\r
- <pile> [ <scroller> @right grid-add ] keep >>userlist ;\r
-\r
-: update-participants ( tab -- )\r
- [ userlist>> [ clear-gadget ] keep ]\r
- [ chat>> participants>> ] bi\r
- [ +operator+ value-labels dark-green add-gadget-color ]\r
- [ +voice+ value-labels blue add-gadget-color ]\r
- [ +normal+ value-labels black add-gadget-color ] tri drop ;\r
-\r
-M: participant-changed handle-inbox\r
- drop update-participants ;\r
-\r
-TUPLE: irc-server-tab < irc-tab ;\r
-\r
-: <irc-server-tab> ( chat -- irc-tab )\r
- f irc-server-tab new-irc-tab ;\r
-\r
-: <irc-nick-tab> ( chat ui-window -- irc-tab )\r
- irc-tab new-irc-tab ;\r
-\r
-M: irc-tab pref-dim*\r
- drop { 480 480 } ;\r
-\r
-: join-channel ( name ui-window -- )\r
- [ dup <irc-channel-chat> ] dip\r
- [ <irc-channel-tab> swap ] keep\r
- add-page ;\r
-\r
-: query-nick ( nick ui-window -- )\r
- [ dup <irc-nick-chat> ] dip\r
- [ <irc-nick-tab> swap ] keep\r
- add-page ;\r
-\r
-: irc-window ( ui-window -- )\r
- [ ]\r
- [ client>> profile>> server>> ] bi\r
- open-window ;\r
-\r
-: ui-connect ( profile -- ui-window )\r
- <irc-client>\r
- { [ [ <irc-server-chat> ] dip attach-chat ]\r
- [ chats>> +server-chat+ swap at <irc-server-tab> dup\r
- "Server" associate ui-window new-tabbed [ swap (>>window) ] keep ]\r
- [ >>client ]\r
- [ connect-irc ] } cleave ;\r
-\r
-: server-open ( server port nick password channels -- )\r
- [ <irc-profile> ui-connect [ irc-window ] keep ] dip\r
- [ over join-channel ] each drop ;\r
-\r
-: main-run ( -- ) run-ircui ;\r
-\r
-MAIN: main-run\r
-\r
-"irc.ui.commands" require\r
USING: ui ui.gadgets sequences kernel arrays math colors
-ui.render math.vectors accessors fry ui.gadgets.packs game-input
-ui.gadgets.labels ui.gadgets.borders alarms
-calendar locals strings ui.gadgets.buttons
+colors.constants ui.render ui.pens.polygon ui.pens.solid math.vectors
+accessors fry ui.gadgets.packs game-input ui.gadgets.labels
+ui.gadgets.borders alarms calendar locals strings ui.gadgets.buttons
combinators math.parser assocs threads ;
IN: joystick-demo
[ z-indicator>> (>>loc) ] 2bi* ;
: move-pov ( gadget pov -- )
- swap pov>> [ interior>> -rot = [ gray ] [ white ] if >>color drop ]
+ swap pov>> [ interior>> -rot = COLOR: gray COLOR: white ? >>color drop ]
with assoc-each ;
:: add-pov-gadget ( gadget direction polygon -- gadget direction gadget )
- gadget white polygon <polygon-gadget> [ add-gadget ] keep
+ gadget
COLOR: white polygon <polygon-gadget> [ add-gadget ] keep
direction swap ;
: add-pov-gadgets ( gadget -- gadget )
: <axis-gadget> ( -- gadget )
axis-gadget new
add-pov-gadgets
- black <indicator-gadget> [ >>z-indicator ] [ add-gadget ] bi
- red <indicator-gadget> [ >>indicator ] [ add-gadget ] bi
+ COLOR: black <indicator-gadget> [ >>z-indicator ] [ add-gadget ] bi
+ COLOR: red <indicator-gadget> [ >>indicator ] [ add-gadget ] bi
dup [ 0.0 0.0 0.0 move-axis ] [ f move-pov ] bi ;
TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;
: add-gadget-with-border ( parent child -- parent )
- { 2 2 } <border> gray <solid> >>boundary add-gadget ;
+ { 2 2 } <border> COLOR: gray <solid> >>boundary add-gadget ;
: add-controller-label ( gadget controller -- gadget )
[ >>controller ] [ product-string <label> add-gadget ] bi ;
:: (add-button-gadgets) ( gadget shelf -- )
gadget controller>> read-controller buttons>> length [
- number>string [ ] <bevel-button>
+ number>string [ drop ] <border-button>
shelf over add-gadget drop
] map gadget (>>buttons) ;
[ >>selected? drop ] 2each ;
: kill-update-axes ( gadget -- )
- gray <solid> >>interior
+ COLOR: gray <solid> >>interior
[ [ cancel-alarm ] when* f ] change-alarm
relayout-1 ;
: make-key-gadget ( scancode dim array -- )
[
swap [
- " " [ drop ] <bevel-button>
+ " " [ drop ] <border-button>
swap [ first >>loc ] [ second >>dim ] bi
] [ execute ] bi*
] dip set-nth ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences kernel math io calendar grouping
-calendar.format calendar.model arrays models models.arrow
-namespaces ui.gadgets ui.gadgets.labels ui.gadgets.theme ui ;
+calendar.format calendar.model fonts arrays models models.arrow
+namespaces ui.gadgets ui.gadgets.labels ui ;
IN: lcd
: lcd-digit ( row digit -- str )
! From http://www.ffconsultancy.com/ocaml/maze/index.html
USING: sequences namespaces math math.vectors opengl opengl.gl
arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render
-math.order math.rectangles ;
+math.order math.rectangles accessors ;
IN: maze
CONSTANT: line-width 8
: nehe-window ( -- )
[
<filled-pile>
- "Nehe 2" [ drop run2 ] <bevel-button> add-gadget
- "Nehe 3" [ drop run3 ] <bevel-button> add-gadget
- "Nehe 4" [ drop run4 ] <bevel-button> add-gadget
- "Nehe 5" [ drop run5 ] <bevel-button> add-gadget
+ "Nehe 2" [ drop run2 ] <border-button> add-gadget
+ "Nehe 3" [ drop run3 ] <border-button> add-gadget
+ "Nehe 4" [ drop run4 ] <border-button> add-gadget
+ "Nehe 5" [ drop run5 ] <border-button> add-gadget
"Nehe examples" open-window
] with-ui ;
new
swap >>distance
swap >>pitch
- swap >>yaw ;
+ swap >>yaw ; inline
GENERIC: far-plane ( gadget -- z )
GENERIC: near-plane ( gadget -- z )
{ 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 over distance-step * swap zoom-demo-gadget ] }
+ { mouse-scroll [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] }
} set-gestures
+++ /dev/null
-
-USING: kernel accessors locals math math.intervals math.order
- namespaces sequences threads
- ui
- ui.gadgets
- ui.gestures
- ui.render
- calendar
- multi-methods
- multi-method-syntax
- combinators.short-circuit.smart
- combinators.cleave.enhanced
- processing.shapes
- flatland ;
-
-IN: pong
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431
-!
-! Which was based on this Nodebox version: http://billmill.org/pong.html
-! by Bill Mill.
-!
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: clamp-to-interval ( x interval -- x )
- [ from>> first max ] [ to>> first min ] bi ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <play-field> < <rectangle> ;
-TUPLE: <paddle> < <rectangle> ;
-
-TUPLE: <computer> < <paddle> { speed initial: 10 } ;
-
-: computer-move-left ( computer -- ) dup speed>> move-left-by ;
-: computer-move-right ( computer -- ) dup speed>> move-right-by ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <ball> < <vel>
- { diameter initial: 20 }
- { bounciness initial: 1.2 }
- { max-speed initial: 10 } ;
-
-: above-lower-bound? ( ball field -- ? ) bottom 50 - above? ;
-: below-upper-bound? ( ball field -- ? ) top 50 + below? ;
-
-: in-bounds? ( ball field -- ? )
- {
- [ above-lower-bound? ]
- [ below-upper-bound? ]
- } && ;
-
-:: bounce-change-vertical-velocity ( BALL -- )
-
- BALL vel>> y neg
- BALL bounciness>> *
-
- BALL max-speed>> min
-
- BALL vel>> (y!) ;
-
-:: bounce-off-paddle ( BALL PADDLE -- )
-
- BALL bounce-change-vertical-velocity
-
- BALL x PADDLE center x - 0.25 * BALL vel>> (x!)
-
- PADDLE top BALL pos>> (y!) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: mouse-x ( -- x ) hand-loc get first ;
-
-:: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval )
-
- PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ;
-
-:: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- )
-
- mouse-x
-
- PADDLE PLAY-FIELD valid-paddle-interval
-
- clamp-to-interval
-
- PADDLE pos>> (x!) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Protocol for drawing PONG objects
-
-GENERIC: draw ( obj -- )
-
-METHOD: draw ( <paddle> -- ) [ bottom-left ] [ dim>> ] bi rectangle ;
-METHOD: draw ( <ball> -- ) [ pos>> ] [ diameter>> 2 / ] bi circle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided
- ! by multi-methods
-
-TUPLE: <pong> < gadget paused field ball player computer ;
-
-: pong ( -- gadget )
- <pong> new-gadget
- T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } clone >>field
- T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } clone >>ball
- T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } clone >>player
- T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } clone >>computer ;
-
-M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
-M: <pong> ungraft* ( <pong> -- ) t >>paused drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <pong> draw-gadget* ( PONG -- )
-
- PONG computer>> draw
- PONG player>> draw
- PONG ball>> draw ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: iterate-system ( GADGET -- )
-
- [let | FIELD [ GADGET field>> ]
- BALL [ GADGET ball>> ]
- PLAYER [ GADGET player>> ]
- COMPUTER [ GADGET computer>> ] |
-
- [wlet | align-player-with-mouse [ ( -- )
- PLAYER FIELD align-paddle-with-mouse ]
-
- move-ball [ ( -- ) BALL 1 move-for ]
-
- player-blocked-ball? [ ( -- ? )
- BALL PLAYER { [ above? ] [ in-between-horizontally? ] } && ]
-
- computer-blocked-ball? [ ( -- ? )
- BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ]
-
- bounce-off-wall? [ ( -- ? )
- BALL FIELD in-between-horizontally? not ]
-
- stop-game [ ( -- ) t GADGET (>>paused) ] |
-
- BALL FIELD in-bounds?
- [
-
- align-player-with-mouse
-
- move-ball
-
- ! computer reaction
-
- BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
- BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
-
- ! check if ball bounced off something
-
- player-blocked-ball? [ BALL PLAYER bounce-off-paddle ] when
- computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle ] when
- bounce-off-wall? [ BALL reverse-horizontal-velocity ] when
- ]
- [ stop-game ]
- if
-
- ] ] ( gadget -- ) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: start-pong-thread ( GADGET -- )
- f GADGET (>>paused)
- [
- [
- GADGET paused>>
- [ f ]
- [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
- if
- ]
- loop
- ]
- in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pong-window ( -- ) pong [ "PONG" open-window ] [ start-pong-thread ] bi ;
-
-: pong-main ( -- ) [ pong-window ] with-ui ;
-
-MAIN: pong-window
\ No newline at end of file
+++ /dev/null
-
-USING: kernel namespaces arrays sequences grouping
- alien.c-types
- math math.vectors math.geometry.rect
- opengl.gl opengl.glu opengl generalizations vars
- combinators.cleave colors ;
-
-IN: processing.shapes
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: do-state ( mode quot -- ) swap glBegin call glEnd ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: fill-color
-VAR: stroke-color
-
-T{ rgba f 0 0 0 1 } stroke-color set-global
-T{ rgba f 1 1 1 1 } fill-color set-global
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: fill-mode ( -- )
- GL_FRONT_AND_BACK GL_FILL glPolygonMode
- fill-color> gl-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: stroke-mode ( -- )
- GL_FRONT_AND_BACK GL_LINE glPolygonMode
- stroke-color> gl-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-vertex-2d ( vertex -- ) first2 glVertex2d ;
-
-: gl-vertices-2d ( vertices -- ) [ gl-vertex-2d ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: point* ( x y -- ) stroke-mode GL_POINTS [ glVertex2d ] do-state ;
-: point ( point -- ) stroke-mode GL_POINTS [ gl-vertex-2d ] do-state ;
-: points ( points -- ) stroke-mode GL_POINTS [ gl-vertices-2d ] do-state ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: line** ( x y x y -- )
- stroke-mode GL_LINES [ glVertex2d glVertex2d ] do-state ;
-
-: line* ( a b -- ) stroke-mode GL_LINES [ [ gl-vertex-2d ] bi@ ] do-state ;
-
-: lines ( seq -- ) stroke-mode GL_LINES [ gl-vertices-2d ] do-state ;
-
-: line ( seq -- ) lines ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: line-strip ( seq -- ) stroke-mode GL_LINE_STRIP [ gl-vertices-2d ] do-state ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: triangles ( seq -- )
- [ fill-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ]
- [ stroke-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ] bi ;
-
-: triangle ( seq -- ) triangles ;
-
-: triangle* ( a b c -- ) 3array triangles ;
-
-: triangle** ( x y x y x y -- ) 6 narray 2 group triangles ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: polygon ( seq -- )
- [ fill-mode GL_POLYGON [ gl-vertices-2d ] do-state ]
- [ stroke-mode GL_POLYGON [ gl-vertices-2d ] do-state ] bi ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: rectangle ( loc dim -- )
- <rect>
- { top-left top-right bottom-right bottom-left }
- 1arr
- polygon ;
-
-: rectangle* ( x y width height -- ) [ 2array ] 2bi@ rectangle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-translate-2d ( pos -- ) first2 0 glTranslated ;
-
-: gl-scale-2d ( xy -- ) first2 1 glScaled ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-ellipse ( center dim -- )
- glPushMatrix
- [ gl-translate-2d ] [ gl-scale-2d ] bi*
- gluNewQuadric
- dup 0 0.5 20 1 gluDisk
- gluDeleteQuadric
- glPopMatrix ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-get-line-width ( -- width )
- GL_LINE_WIDTH 0 <double> tuck glGetDoublev *double ;
-
-: ellipse ( center dim -- )
- GL_FRONT_AND_BACK GL_FILL glPolygonMode
- [ stroke-color> gl-color gl-ellipse ]
- [ fill-color> gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: circle ( center size -- ) dup 2array ellipse ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables help.markup help.stylesheet io
io.styles kernel math models namespaces sequences ui ui.gadgets
-ui.gadgets.books ui.gadgets.panes ui.gestures ui.render
+ui.gadgets.books ui.gadgets.panes ui.gestures ui.pens.gradient ui.render
parser accessors colors ;
IN: slides
H{
{ default-span-style
H{
- { font "sans-serif" }
+ { font-name "sans-serif" }
{ font-size 36 }
}
}
}
{ code-style
H{
- { font "monospace" }
+ { font-name "monospace" }
{ font-size 36 }
{ page-color T{ rgba f 0.4 0.4 0.4 0.3 } }
}
}
{ snippet-style
H{
- { font "monospace" }
+ { font-name "monospace" }
{ font-size 36 }
{ foreground T{ rgba f 0.1 0.1 0.4 1 } }
}
{ list-style
H{ { table-gap { 10 20 } } }
}
- { bullet "\u0000b7" }
}
: $title ( string -- )
- [ H{ { font "sans-serif" } { font-size 48 } } format ] ($block) ;
+ [ H{ { font-name "sans-serif" } { font-size 48 } } format ] ($block) ;
: $divider ( -- )
[
-USING: kernel opengl opengl.demo-support opengl.gl
+USING: kernel opengl opengl.demo-support opengl.gl opengl.textures
opengl.shaders opengl.framebuffers opengl.capabilities multiline
ui.gadgets accessors sequences ui.render ui math locals arrays
generalizations combinators ui.gadgets.worlds ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences math math.vectors random
- springies springies.ui ;
-
-IN: springies.models.2snake
-
-: model ( -- )
-
-{ } clone >nodes
-{ } clone >springs
-0.001 >time-slice
-gravity off
-
-1 19.0 328.0 0.0 0.0 1.0 1.0 mass
-2 36.0 328.0 0.0 0.0 1.0 1.0 mass
-3 54.0 328.0 0.0 0.0 1.0 1.0 mass
-4 72.0 328.0 0.0 0.0 1.0 1.0 mass
-5 90.0 328.0 0.0 0.0 1.0 1.0 mass
-6 108.0 328.0 0.0 0.0 1.0 1.0 mass
-7 126.0 328.0 0.0 0.0 1.0 1.0 mass
-8 144.0 328.0 0.0 0.0 1.0 1.0 mass
-9 162.0 328.0 0.0 0.0 1.0 1.0 mass
-10 180.0 328.0 0.0 0.0 1.0 1.0 mass
-11 198.0 328.0 0.0 0.0 1.0 1.0 mass
-12 216.0 328.0 0.0 0.0 1.0 1.0 mass
-13 234.0 328.0 0.0 0.0 1.0 1.0 mass
-14 252.0 328.0 0.0 0.0 1.0 1.0 mass
-15 270.0 328.0 0.0 0.0 1.0 1.0 mass
-16 288.0 328.0 0.0 0.0 1.0 1.0 mass
-17 306.0 328.0 0.0 0.0 1.0 1.0 mass
-18 324.0 328.0 0.0 0.0 1.0 1.0 mass
-19 342.0 328.0 0.0 0.0 1.0 1.0 mass
-20 360.0 328.0 0.0 0.0 1.0 1.0 mass
-21 378.0 328.0 0.0 0.0 1.0 1.0 mass
-22 396.0 328.0 0.0 0.0 1.0 1.0 mass
-23 414.0 328.0 0.0 0.0 1.0 1.0 mass
-24 432.0 328.0 0.0 0.0 1.0 1.0 mass
-25 450.0 328.0 0.0 0.0 1.0 1.0 mass
-26 468.0 328.0 0.0 0.0 1.0 1.0 mass
-27 504.0 328.0 0.0 0.0 1.0 1.0 mass
-28 486.0 328.0 0.0 0.0 1.0 1.0 mass
-29 522.0 328.0 0.0 0.0 1.0 1.0 mass
-30 540.0 328.0 0.0 0.0 1.0 1.0 mass
-31 558.0 328.0 0.0 0.0 1.0 1.0 mass
-32 576.0 328.0 0.0 0.0 1.0 1.0 mass
-33 594.0 328.0 0.0 0.0 1.0 1.0 mass
-34 612.0 328.0 0.0 0.0 1.0 1.0 mass
-35 630.0 328.0 0.0 0.0 1.0 1.0 mass
-1 1 2 200.0 1.500000 18.0 spng
-2 3 2 200.0 1.500000 18.0 spng
-3 3 4 200.0 1.500000 18.0 spng
-4 4 5 200.0 1.500000 18.0 spng
-5 5 6 200.0 1.500000 18.0 spng
-6 6 7 200.0 1.500000 18.0 spng
-7 7 8 200.0 1.500000 18.0 spng
-8 8 9 200.0 1.500000 18.0 spng
-9 9 10 200.0 1.500000 18.0 spng
-10 10 11 200.0 1.500000 18.0 spng
-11 11 12 200.0 1.500000 18.0 spng
-12 12 13 200.0 1.500000 18.0 spng
-13 13 14 200.0 1.500000 18.0 spng
-14 14 15 200.0 1.500000 18.0 spng
-15 15 16 200.0 1.500000 18.0 spng
-16 16 17 200.0 1.500000 18.0 spng
-17 17 18 200.0 1.500000 18.0 spng
-18 18 19 200.0 1.500000 18.0 spng
-19 19 20 200.0 1.500000 18.0 spng
-20 20 21 200.0 1.500000 18.0 spng
-21 21 22 200.0 1.500000 18.0 spng
-22 22 23 200.0 1.500000 18.0 spng
-23 23 24 200.0 1.500000 18.0 spng
-24 24 25 200.0 1.500000 18.0 spng
-25 25 26 200.0 1.500000 18.0 spng
-26 26 28 200.0 1.500000 18.0 spng
-27 28 27 200.0 1.500000 18.0 spng
-28 27 29 200.0 1.500000 18.0 spng
-29 29 30 200.0 1.500000 18.0 spng
-30 30 31 200.0 1.500000 18.0 spng
-31 31 32 200.0 1.500000 18.0 spng
-32 32 33 200.0 1.500000 18.0 spng
-33 33 34 200.0 1.500000 18.0 spng
-34 34 35 200.0 1.500000 18.0 spng
-35 1 3 200.0 1.500000 36.0 spng
-36 2 4 200.0 1.500000 36.0 spng
-37 3 5 200.0 1.500000 36.0 spng
-38 4 6 200.0 1.500000 36.0 spng
-39 5 7 200.0 1.500000 36.0 spng
-40 6 8 200.0 1.500000 36.0 spng
-41 7 9 200.0 1.500000 36.0 spng
-42 8 10 200.0 1.500000 36.0 spng
-43 9 11 200.0 1.500000 36.0 spng
-44 10 12 200.0 1.500000 36.0 spng
-45 11 13 200.0 1.500000 36.0 spng
-46 12 14 200.0 1.500000 36.0 spng
-47 13 15 200.0 1.500000 36.0 spng
-48 14 16 200.0 1.500000 36.0 spng
-49 15 17 200.0 1.500000 36.0 spng
-50 16 18 200.0 1.500000 36.0 spng
-51 17 19 200.0 1.500000 36.0 spng
-52 18 20 200.0 1.500000 36.0 spng
-53 19 21 200.0 1.500000 36.0 spng
-54 20 22 200.0 1.500000 36.0 spng
-55 21 23 200.0 1.500000 36.0 spng
-56 22 24 200.0 1.500000 36.0 spng
-57 23 25 200.0 1.500000 36.0 spng
-58 24 26 200.0 1.500000 36.0 spng
-59 25 28 200.0 1.500000 36.0 spng
-60 26 27 200.0 1.500000 36.0 spng
-61 28 29 200.0 1.500000 36.0 spng
-62 27 30 200.0 1.500000 36.0 spng
-63 29 31 200.0 1.500000 36.0 spng
-64 30 32 200.0 1.500000 36.0 spng
-65 31 33 200.0 1.500000 36.0 spng
-66 32 34 200.0 1.500000 36.0 spng
-67 33 35 200.0 1.500000 36.0 spng
-
-nodes> [ 400 random -200 + 400 random -200 + 2array swap set-node-vel ] each ;
-
-USING: threads ui ;
-
-: go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ;
-
-MAIN: go
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences threads math math.vectors
- ui random springies springies.ui ;
-
-IN: springies.models.2x2snake
-
-: model ( -- )
-
-{ } clone >nodes
-{ } clone >springs
-0.002 >time-slice
-gravity off
-
-1 147.0 324.0 0.0 0.0 1.0 1.0 mass
-2 164.0 324.0 0.0 0.0 1.0 1.0 mass
-3 182.0 324.0 0.0 0.0 1.0 1.0 mass
-4 200.0 324.0 0.0 0.0 1.0 1.0 mass
-5 218.0 324.0 0.0 0.0 1.0 1.0 mass
-6 236.0 324.0 0.0 0.0 1.0 1.0 mass
-7 254.0 324.0 0.0 0.0 1.0 1.0 mass
-8 272.0 324.0 0.0 0.0 1.0 1.0 mass
-9 290.0 324.0 0.0 0.0 1.0 1.0 mass
-10 308.0 324.0 0.0 0.0 1.0 1.0 mass
-11 326.0 324.0 0.0 0.0 1.0 1.0 mass
-12 344.0 324.0 0.0 0.0 1.0 1.0 mass
-13 362.0 324.0 0.0 0.0 1.0 1.0 mass
-14 380.0 324.0 0.0 0.0 1.0 1.0 mass
-15 398.0 324.0 0.0 0.0 1.0 1.0 mass
-16 416.0 324.0 0.0 0.0 1.0 1.0 mass
-17 434.0 324.0 0.0 0.0 1.0 1.0 mass
-18 452.0 324.0 0.0 0.0 1.0 1.0 mass
-19 470.0 324.0 0.0 0.0 1.0 1.0 mass
-20 147.0 298.0 0.0 0.0 1.0 1.0 mass
-21 164.0 298.0 0.0 0.0 1.0 1.0 mass
-22 182.0 298.0 0.0 0.0 1.0 1.0 mass
-23 200.0 298.0 0.0 0.0 1.0 1.0 mass
-24 218.0 298.0 0.0 0.0 1.0 1.0 mass
-25 236.0 298.0 0.0 0.0 1.0 1.0 mass
-26 254.0 298.0 0.0 0.0 1.0 1.0 mass
-27 272.0 298.0 0.0 0.0 1.0 1.0 mass
-28 290.0 298.0 0.0 0.0 1.0 1.0 mass
-29 308.0 298.0 0.0 0.0 1.0 1.0 mass
-30 326.0 298.0 0.0 0.0 1.0 1.0 mass
-31 344.0 298.0 0.0 0.0 1.0 1.0 mass
-32 362.0 298.0 0.0 0.0 1.0 1.0 mass
-33 380.0 298.0 0.0 0.0 1.0 1.0 mass
-34 398.0 298.0 0.0 0.0 1.0 1.0 mass
-35 416.0 298.0 0.0 0.0 1.0 1.0 mass
-36 434.0 298.0 0.0 0.0 1.0 1.0 mass
-37 452.0 298.0 0.0 0.0 1.0 1.0 mass
-38 470.0 298.0 0.0 0.0 1.0 1.0 mass
-1 1 2 200.0 1.500000 18.0 spng
-2 3 2 200.0 1.500000 18.0 spng
-3 3 4 200.0 1.500000 18.0 spng
-4 4 5 200.0 1.500000 18.0 spng
-5 5 6 200.0 1.500000 18.0 spng
-6 6 7 200.0 1.500000 18.0 spng
-7 7 8 200.0 1.500000 18.0 spng
-8 8 9 200.0 1.500000 18.0 spng
-9 9 10 200.0 1.500000 18.0 spng
-10 10 11 200.0 1.500000 18.0 spng
-11 11 12 200.0 1.500000 18.0 spng
-12 12 13 200.0 1.500000 18.0 spng
-13 13 14 200.0 1.500000 18.0 spng
-14 14 15 200.0 1.500000 18.0 spng
-15 15 16 200.0 1.500000 18.0 spng
-16 16 17 200.0 1.500000 18.0 spng
-17 17 18 200.0 1.500000 18.0 spng
-18 18 19 200.0 1.500000 18.0 spng
-19 1 3 200.0 1.500000 36.0 spng
-20 2 4 200.0 1.500000 36.0 spng
-21 3 5 200.0 1.500000 36.0 spng
-22 4 6 200.0 1.500000 36.0 spng
-23 5 7 200.0 1.500000 36.0 spng
-24 6 8 200.0 1.500000 36.0 spng
-25 7 9 200.0 1.500000 36.0 spng
-26 8 10 200.0 1.500000 36.0 spng
-27 9 11 200.0 1.500000 36.0 spng
-28 10 12 200.0 1.500000 36.0 spng
-29 11 13 200.0 1.500000 36.0 spng
-30 12 14 200.0 1.500000 36.0 spng
-31 13 15 200.0 1.500000 36.0 spng
-32 14 16 200.0 1.500000 36.0 spng
-33 15 17 200.0 1.500000 36.0 spng
-34 16 18 200.0 1.500000 36.0 spng
-35 17 19 200.0 1.500000 36.0 spng
-36 20 21 200.0 1.500000 18.0 spng
-37 22 21 200.0 1.500000 18.0 spng
-38 22 23 200.0 1.500000 18.0 spng
-39 23 24 200.0 1.500000 18.0 spng
-40 24 25 200.0 1.500000 18.0 spng
-41 25 26 200.0 1.500000 18.0 spng
-42 26 27 200.0 1.500000 18.0 spng
-43 27 28 200.0 1.500000 18.0 spng
-44 28 29 200.0 1.500000 18.0 spng
-45 29 30 200.0 1.500000 18.0 spng
-46 30 31 200.0 1.500000 18.0 spng
-47 31 32 200.0 1.500000 18.0 spng
-48 32 33 200.0 1.500000 18.0 spng
-49 33 34 200.0 1.500000 18.0 spng
-50 34 35 200.0 1.500000 18.0 spng
-51 35 36 200.0 1.500000 18.0 spng
-52 36 37 200.0 1.500000 18.0 spng
-53 37 38 200.0 1.500000 18.0 spng
-54 20 22 200.0 1.500000 36.0 spng
-55 21 23 200.0 1.500000 36.0 spng
-56 22 24 200.0 1.500000 36.0 spng
-57 23 25 200.0 1.500000 36.0 spng
-58 24 26 200.0 1.500000 36.0 spng
-59 25 27 200.0 1.500000 36.0 spng
-60 26 28 200.0 1.500000 36.0 spng
-61 27 29 200.0 1.500000 36.0 spng
-62 28 30 200.0 1.500000 36.0 spng
-63 29 31 200.0 1.500000 36.0 spng
-64 30 32 200.0 1.500000 36.0 spng
-65 31 33 200.0 1.500000 36.0 spng
-66 32 34 200.0 1.500000 36.0 spng
-67 33 35 200.0 1.500000 36.0 spng
-68 34 36 200.0 1.500000 36.0 spng
-69 35 37 200.0 1.500000 36.0 spng
-70 36 38 200.0 1.500000 36.0 spng
-71 1 20 200.0 1.500000 26.0 spng
-72 2 21 200.0 1.500000 26.0 spng
-73 3 22 200.0 1.500000 26.0 spng
-74 4 23 200.0 1.500000 26.0 spng
-75 5 24 200.0 1.500000 26.0 spng
-76 25 6 200.0 1.500000 26.0 spng
-77 7 26 200.0 1.500000 26.0 spng
-78 27 8 200.0 1.500000 26.0 spng
-79 9 28 200.0 1.500000 26.0 spng
-80 29 10 200.0 1.500000 26.0 spng
-81 11 30 200.0 1.500000 26.0 spng
-82 31 12 200.0 1.500000 26.0 spng
-83 13 32 200.0 1.500000 26.0 spng
-84 33 14 200.0 1.500000 26.0 spng
-85 15 34 200.0 1.500000 26.0 spng
-86 35 16 200.0 1.500000 26.0 spng
-87 17 36 200.0 1.500000 26.0 spng
-88 37 18 200.0 1.500000 26.0 spng
-89 19 38 200.0 1.500000 26.0 spng
-90 1 21 200.0 1.500000 31.064449 spng
-91 2 20 200.0 1.500000 31.064449 spng
-92 2 22 200.0 1.500000 31.622777 spng
-93 3 21 200.0 1.500000 31.622777 spng
-94 3 23 200.0 1.500000 31.622777 spng
-95 4 22 200.0 1.500000 31.622777 spng
-96 4 24 200.0 1.500000 31.622777 spng
-97 5 23 200.0 1.500000 31.622777 spng
-98 5 25 200.0 1.500000 31.622777 spng
-99 6 24 200.0 1.500000 31.622777 spng
-100 6 26 200.0 1.500000 31.622777 spng
-101 7 25 200.0 1.500000 31.622777 spng
-102 7 27 200.0 1.500000 31.622777 spng
-103 8 26 200.0 1.500000 31.622777 spng
-104 8 28 200.0 1.500000 31.622777 spng
-105 9 27 200.0 1.500000 31.622777 spng
-106 9 29 200.0 1.500000 31.622777 spng
-107 10 28 200.0 1.500000 31.622777 spng
-108 10 30 200.0 1.500000 31.622777 spng
-109 11 29 200.0 1.500000 31.622777 spng
-110 11 31 200.0 1.500000 31.622777 spng
-111 12 30 200.0 1.500000 31.622777 spng
-112 12 32 200.0 1.500000 31.622777 spng
-113 13 31 200.0 1.500000 31.622777 spng
-114 13 33 200.0 1.500000 31.622777 spng
-115 14 32 200.0 1.500000 31.622777 spng
-116 14 34 200.0 1.500000 31.622777 spng
-117 15 33 200.0 1.500000 31.622777 spng
-118 15 35 200.0 1.500000 31.622777 spng
-119 16 34 200.0 1.500000 31.622777 spng
-120 16 36 200.0 1.500000 31.622777 spng
-121 17 35 200.0 1.500000 31.622777 spng
-122 17 37 200.0 1.500000 31.622777 spng
-123 18 36 200.0 1.500000 31.622777 spng
-124 18 38 200.0 1.500000 31.622777 spng
-125 19 37 200.0 1.500000 31.622777 spng
-126 1 22 200.0 1.500000 43.600459 spng
-127 3 20 200.0 1.500000 43.600459 spng
-128 2 23 200.0 1.500000 44.407207 spng
-129 4 21 200.0 1.500000 44.407207 spng
-130 3 24 200.0 1.500000 44.407207 spng
-131 5 22 200.0 1.500000 44.407207 spng
-132 4 25 200.0 1.500000 44.407207 spng
-133 6 23 200.0 1.500000 44.407207 spng
-134 5 26 200.0 1.500000 44.407207 spng
-135 7 24 200.0 1.500000 44.407207 spng
-136 6 27 200.0 1.500000 44.407207 spng
-137 8 25 200.0 1.500000 44.407207 spng
-138 7 28 200.0 1.500000 44.407207 spng
-139 9 26 200.0 1.500000 44.407207 spng
-140 8 29 200.0 1.500000 44.407207 spng
-141 10 27 200.0 1.500000 44.407207 spng
-142 9 30 200.0 1.500000 44.407207 spng
-143 11 28 200.0 1.500000 44.407207 spng
-144 10 31 200.0 1.500000 44.407207 spng
-145 12 29 200.0 1.500000 44.407207 spng
-146 11 32 200.0 1.500000 44.407207 spng
-147 13 30 200.0 1.500000 44.407207 spng
-148 12 33 200.0 1.500000 44.407207 spng
-149 14 31 200.0 1.500000 44.407207 spng
-150 13 34 200.0 1.500000 44.407207 spng
-151 15 33 200.0 1.500000 31.622777 spng
-152 32 15 200.0 1.500000 44.407207 spng
-153 14 35 200.0 1.500000 44.407207 spng
-154 16 33 200.0 1.500000 44.407207 spng
-155 15 36 200.0 1.500000 44.407207 spng
-156 34 17 200.0 1.500000 44.407207 spng
-157 16 37 200.0 1.500000 44.407207 spng
-158 18 35 200.0 1.500000 44.407207 spng
-159 17 38 200.0 1.500000 44.407207 spng
-160 19 36 200.0 1.500000 44.407207 spng
-
-! Send the half of the snake in a random direction
-
-nodes> 10 [ swap nth ] with map
-nodes> 10 [ 19 + swap nth ] with map append
-100 random -50 + 100 random 100 + { -1 1 } random * 2array
-[ swap set-node-vel ] curry
-each ;
-
-: go ( -- ) [ model ] go* ;
-
-MAIN: go
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: tools.deploy.config ;
-H{
- { deploy-compiler? t }
- { deploy-word-props? f }
- { deploy-ui? t }
- { deploy-reflection 1 }
- { deploy-name "springies.models.2x2snake" }
- { deploy-c-types? f }
- { deploy-word-defs? f }
- { "stop-after-last-window?" t }
- { deploy-math? t }
- { deploy-io 1 }
-}
+++ /dev/null
-
-USING: kernel namespaces arrays sequences threads math ui random fry
- springies springies.ui ;
-
-IN: springies.models.3snake
-
-: random-range ( a b -- n ) 1+ over - random + ;
-
-: model ( -- )
-
-{ } clone >nodes
-{ } clone >springs
-0.001 >time-slice
-gravity off
-
-1 19.0 328.0 0.0 0.0 1.0 1.0 mass
-2 36.0 328.0 0.0 0.0 1.0 1.0 mass
-3 54.0 328.0 0.0 0.0 1.0 1.0 mass
-4 72.0 328.0 0.0 0.0 1.0 1.0 mass
-5 90.0 328.0 0.0 0.0 1.0 1.0 mass
-6 108.0 328.0 0.0 0.0 1.0 1.0 mass
-7 126.0 328.0 0.0 0.0 1.0 1.0 mass
-8 144.0 328.0 0.0 0.0 1.0 1.0 mass
-9 162.0 328.0 0.0 0.0 1.0 1.0 mass
-10 180.0 328.0 0.0 0.0 1.0 1.0 mass
-11 198.0 328.0 0.0 0.0 1.0 1.0 mass
-12 216.0 328.0 0.0 0.0 1.0 1.0 mass
-13 234.0 328.0 0.0 0.0 1.0 1.0 mass
-14 252.0 328.0 0.0 0.0 1.0 1.0 mass
-15 270.0 328.0 0.0 0.0 1.0 1.0 mass
-16 288.0 328.0 0.0 0.0 1.0 1.0 mass
-17 306.0 328.0 0.0 0.0 1.0 1.0 mass
-18 324.0 328.0 0.0 0.0 1.0 1.0 mass
-19 342.0 328.0 0.0 0.0 1.0 1.0 mass
-20 360.0 328.0 0.0 0.0 1.0 1.0 mass
-21 378.0 328.0 0.0 0.0 1.0 1.0 mass
-22 396.0 328.0 0.0 0.0 1.0 1.0 mass
-23 414.0 328.0 0.0 0.0 1.0 1.0 mass
-24 432.0 328.0 0.0 0.0 1.0 1.0 mass
-25 450.0 328.0 0.0 0.0 1.0 1.0 mass
-26 468.0 328.0 0.0 0.0 1.0 1.0 mass
-27 504.0 328.0 0.0 0.0 1.0 1.0 mass
-28 486.0 328.0 0.0 0.0 1.0 1.0 mass
-29 522.0 328.0 0.0 0.0 1.0 1.0 mass
-30 540.0 328.0 0.0 0.0 1.0 1.0 mass
-31 558.0 328.0 0.0 0.0 1.0 1.0 mass
-32 576.0 328.0 0.0 0.0 1.0 1.0 mass
-33 594.0 328.0 0.0 0.0 1.0 1.0 mass
-34 612.0 328.0 0.0 0.0 1.0 1.0 mass
-35 626.0 328.0 0.0 0.0 1.0 1.0 mass
-1 1 2 200.0 1.500000 18.0 spng
-2 3 2 200.0 1.500000 18.0 spng
-3 3 4 200.0 1.500000 18.0 spng
-4 4 5 200.0 1.500000 18.0 spng
-5 5 6 200.0 1.500000 18.0 spng
-6 6 7 200.0 1.500000 18.0 spng
-7 7 8 200.0 1.500000 18.0 spng
-8 8 9 200.0 1.500000 18.0 spng
-9 9 10 200.0 1.500000 18.0 spng
-10 10 11 200.0 1.500000 18.0 spng
-11 11 12 200.0 1.500000 18.0 spng
-12 12 13 200.0 1.500000 18.0 spng
-13 13 14 200.0 1.500000 18.0 spng
-14 14 15 200.0 1.500000 18.0 spng
-15 15 16 200.0 1.500000 18.0 spng
-16 16 17 200.0 1.500000 18.0 spng
-17 17 18 200.0 1.500000 18.0 spng
-18 18 19 200.0 1.500000 18.0 spng
-19 19 20 200.0 1.500000 18.0 spng
-20 20 21 200.0 1.500000 18.0 spng
-21 21 22 200.0 1.500000 18.0 spng
-22 22 23 200.0 1.500000 18.0 spng
-23 23 24 200.0 1.500000 18.0 spng
-24 24 25 200.0 1.500000 18.0 spng
-25 25 26 200.0 1.500000 18.0 spng
-26 26 28 200.0 1.500000 18.0 spng
-27 28 27 200.0 1.500000 18.0 spng
-28 27 29 200.0 1.500000 18.0 spng
-29 29 30 200.0 1.500000 18.0 spng
-30 30 31 200.0 1.500000 18.0 spng
-31 31 32 200.0 1.500000 18.0 spng
-32 32 33 200.0 1.500000 18.0 spng
-33 33 34 200.0 1.500000 18.0 spng
-34 34 35 200.0 1.500000 18.0 spng
-35 1 3 200.0 1.500000 36.0 spng
-36 2 4 200.0 1.500000 36.0 spng
-37 3 5 200.0 1.500000 36.0 spng
-38 4 6 200.0 1.500000 36.0 spng
-39 5 7 200.0 1.500000 36.0 spng
-40 6 8 200.0 1.500000 36.0 spng
-41 7 9 200.0 1.500000 36.0 spng
-42 8 10 200.0 1.500000 36.0 spng
-43 9 11 200.0 1.500000 36.0 spng
-44 10 12 200.0 1.500000 36.0 spng
-45 11 13 200.0 1.500000 36.0 spng
-46 12 14 200.0 1.500000 36.0 spng
-47 13 15 200.0 1.500000 36.0 spng
-48 14 16 200.0 1.500000 36.0 spng
-49 15 17 200.0 1.500000 36.0 spng
-50 16 18 200.0 1.500000 36.0 spng
-51 17 19 200.0 1.500000 36.0 spng
-52 18 20 200.0 1.500000 36.0 spng
-53 19 21 200.0 1.500000 36.0 spng
-54 20 22 200.0 1.500000 36.0 spng
-55 21 23 200.0 1.500000 36.0 spng
-56 22 24 200.0 1.500000 36.0 spng
-57 23 25 200.0 1.500000 36.0 spng
-58 24 26 200.0 1.500000 36.0 spng
-59 25 28 200.0 1.500000 36.0 spng
-60 26 27 200.0 1.500000 36.0 spng
-61 28 29 200.0 1.500000 36.0 spng
-62 27 30 200.0 1.500000 36.0 spng
-63 29 31 200.0 1.500000 36.0 spng
-64 30 32 200.0 1.500000 36.0 spng
-65 31 33 200.0 1.500000 36.0 spng
-66 32 34 200.0 1.500000 36.0 spng
-67 33 35 200.0 1.500000 36.0 spng
-68 1 4 200.0 1.500000 53.0 spng
-69 2 5 200.0 1.500000 54.0 spng
-70 3 6 200.0 1.500000 54.0 spng
-71 4 7 200.0 1.500000 54.0 spng
-72 5 8 200.0 1.500000 54.0 spng
-73 6 9 200.0 1.500000 54.0 spng
-74 7 10 200.0 1.500000 54.0 spng
-75 8 11 200.0 1.500000 54.0 spng
-76 9 12 200.0 1.500000 54.0 spng
-77 10 13 200.0 1.500000 54.0 spng
-78 11 14 200.0 1.500000 54.0 spng
-79 12 15 200.0 1.500000 54.0 spng
-80 13 16 200.0 1.500000 54.0 spng
-81 14 17 200.0 1.500000 54.0 spng
-82 15 18 200.0 1.500000 54.0 spng
-83 16 19 200.0 1.500000 54.0 spng
-84 17 20 200.0 1.500000 54.0 spng
-85 18 21 200.0 1.500000 54.0 spng
-86 19 22 200.0 1.500000 54.0 spng
-87 20 23 200.0 1.500000 54.0 spng
-88 21 24 200.0 1.500000 54.0 spng
-89 22 25 200.0 1.500000 54.0 spng
-90 23 26 200.0 1.500000 54.0 spng
-91 24 28 200.0 1.500000 54.0 spng
-92 25 27 200.0 1.500000 54.0 spng
-93 26 29 200.0 1.500000 54.0 spng
-94 28 30 200.0 1.500000 54.0 spng
-95 27 31 200.0 1.500000 54.0 spng
-96 29 32 200.0 1.500000 54.0 spng
-97 30 33 200.0 1.500000 54.0 spng
-98 31 34 200.0 1.500000 54.0 spng
-99 32 35 200.0 1.500000 50.0 spng
-
-10
-[
- -400 400 random-range -400 400 random-range 2array
- nodes> random
- set-node-vel
-]
-times
-
-;
-
-! : go* ( quot -- )
-! [ [ [ springies-window* 1000 sleep % ] with-scope ] with-ui ] bake call ;
-
-: go* ( quot -- ) '[ [ springies-window* 1000 sleep @ ] with-scope ] with-ui ;
-
-! : go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ;
-
-: go ( -- ) [ model ] go* ;
-
-MAIN: go
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces sequences springies springies.ui ;
-
-IN: springies.models.ball
-
-: model ( -- )
-
-{ } clone >nodes
-{ } clone >springs
-0.01 >time-slice
-gravity on
-
-1 325.191871 140.872641 40.832215 -5.301529 1.0 1.0 mass
-2 313.933994 149.011616 55.240875 5.026852 1.0 1.0 mass
-3 309.133386 162.523019 72.798059 5.594199 1.0 1.0 mass
-4 312.887152 176.436760 83.754277 -1.370025 1.0 1.0 mass
-5 321.660596 187.895952 91.634021 -8.308630 1.0 1.0 mass
-6 335.256132 192.503856 94.772924 -18.985044 1.0 1.0 mass
-7 348.254504 188.731936 92.657963 -29.982110 1.0 1.0 mass
-8 359.050972 180.780059 86.668616 -39.817638 1.0 1.0 mass
-9 363.685639 167.752177 76.554871 -47.987107 1.0 1.0 mass
-10 360.449954 154.092353 57.992242 -48.045772 1.0 1.0 mass
-11 352.201411 142.382665 41.200547 -39.924209 1.0 1.0 mass
-12 338.754859 137.460615 32.306364 -22.707784 1.0 1.0 mass
-13 312.911184 114.835962 8.342965 5.878311 1.0 1.0 mass
-14 290.521818 132.872407 33.212103 28.391710 1.0 1.0 mass
-15 281.048450 160.314206 66.319674 32.935324 1.0 1.0 mass
-16 287.450075 188.730522 93.898071 21.966741 1.0 1.0 mass
-17 305.987715 211.206959 112.571044 5.089593 1.0 1.0 mass
-18 333.289699 220.830317 121.166705 -17.204713 1.0 1.0 mass
-19 361.089678 214.901909 117.183695 -41.776506 1.0 1.0 mass
-20 382.690515 197.005784 101.789802 -63.980298 1.0 1.0 mass
-21 392.095364 170.108402 75.453780 -78.414351 1.0 1.0 mass
-22 386.286391 142.033621 41.812216 -77.402424 1.0 1.0 mass
-23 368.355658 119.326317 12.658676 -58.885262 1.0 1.0 mass
-24 341.159901 109.253775 -0.645459 -27.346079 1.0 1.0 mass
-25 300.792976 88.652764 -23.770230 17.788258 1.0 1.0 mass
-26 266.917041 116.942125 11.387083 52.603190 1.0 1.0 mass
-27 252.824303 157.992984 59.144863 62.163730 1.0 1.0 mass
-28 261.812599 201.245775 103.542171 47.141708 1.0 1.0 mass
-29 290.323965 234.792944 133.016945 18.136362 1.0 1.0 mass
-30 330.805232 249.331769 145.899409 -16.478401 1.0 1.0 mass
-31 373.715232 241.181453 141.068680 -55.103677 1.0 1.0 mass
-32 406.314817 213.217096 116.087430 -90.844012 1.0 1.0 mass
-33 420.647493 172.661774 73.304028 -110.880720 1.0 1.0 mass
-34 412.375908 129.697207 24.072484 -106.129512 1.0 1.0 mass
-35 384.555754 95.915740 -16.565355 -77.142380 1.0 1.0 mass
-36 344.134757 80.886540 -34.250916 -30.871105 1.0 1.0 mass
-37 288.774590 62.672780 -55.431084 28.821437 1.0 1.0 mass
-38 244.055965 100.457489 -9.756397 76.701354 1.0 1.0 mass
-39 224.574635 156.693148 53.845562 91.755892 1.0 1.0 mass
-40 235.856891 213.935639 112.462316 73.437061 1.0 1.0 mass
-41 273.697931 257.991035 152.320671 33.701056 1.0 1.0 mass
-42 329.129445 277.782400 170.727571 -15.899371 1.0 1.0 mass
-43 386.065290 267.474982 165.436658 -68.761273 1.0 1.0 mass
-44 429.946314 229.605765 132.087682 -116.795195 1.0 1.0 mass
-45 449.164590 174.189613 73.084826 -143.228528 1.0 1.0 mass
-46 438.674101 117.351918 9.340834 -136.225613 1.0 1.0 mass
-47 401.586435 72.955570 -42.523445 -98.317857 1.0 1.0 mass
-48 346.207804 52.561279 -67.447974 -34.980297 1.0 1.0 mass
-1 1 2 150.0 2.0 14.0 spng
-2 2 3 150.0 2.0 14.0 spng
-3 3 4 150.0 2.0 14.0 spng
-4 4 5 150.0 2.0 14.0 spng
-5 5 6 150.0 2.0 14.0 spng
-6 6 7 150.0 2.0 14.0 spng
-7 7 8 150.0 2.0 14.0 spng
-8 8 9 150.0 2.0 14.0 spng
-9 9 10 150.0 2.0 14.0 spng
-10 10 11 150.0 2.0 14.0 spng
-11 11 12 150.0 2.0 14.0 spng
-12 12 1 150.0 2.0 14.0 spng
-13 13 14 150.0 2.0 28.0 spng
-14 14 15 150.0 2.0 28.0 spng
-15 15 16 150.0 2.0 28.0 spng
-16 16 17 150.0 2.0 28.0 spng
-17 17 18 150.0 2.0 28.0 spng
-18 18 19 150.0 2.0 28.0 spng
-19 19 20 150.0 2.0 28.0 spng
-20 20 21 150.0 2.0 28.0 spng
-21 21 22 150.0 2.0 28.0 spng
-22 22 23 150.0 2.0 28.0 spng
-23 23 24 150.0 2.0 28.0 spng
-24 24 13 150.0 2.0 28.0 spng
-25 25 26 150.0 2.0 44.0 spng
-26 26 27 150.0 2.0 43.0 spng
-27 27 28 150.0 2.0 44.0 spng
-28 28 29 150.0 2.0 44.0 spng
-29 29 30 150.0 2.0 43.0 spng
-30 30 31 150.0 2.0 44.0 spng
-31 31 32 150.0 2.0 43.0 spng
-32 32 33 150.0 2.0 43.0 spng
-33 33 34 150.0 2.0 44.0 spng
-34 34 35 150.0 2.0 44.0 spng
-35 35 36 150.0 2.0 43.0 spng
-36 36 25 150.0 2.0 44.0 spng
-37 37 38 150.0 2.0 58.0 spng
-38 38 39 150.0 2.0 59.0 spng
-39 39 40 150.0 2.0 58.0 spng
-40 40 41 150.0 2.0 58.0 spng
-41 41 42 150.0 2.0 59.0 spng
-42 42 43 150.0 2.0 58.0 spng
-43 43 44 150.0 2.0 58.0 spng
-44 44 45 150.0 2.0 59.0 spng
-45 45 46 150.0 2.0 58.0 spng
-46 46 47 150.0 2.0 58.0 spng
-47 47 48 150.0 2.0 59.0 spng
-48 48 37 150.0 2.0 58.0 spng
-49 1 13 150.0 2.0 29.0 spng
-50 2 14 150.0 2.0 28.0 spng
-51 3 15 150.0 2.0 28.0 spng
-52 4 16 150.0 2.0 29.0 spng
-53 5 17 150.0 2.0 28.0 spng
-54 6 18 150.0 2.0 28.0 spng
-55 7 19 150.0 2.0 29.0 spng
-56 8 20 150.0 2.0 28.0 spng
-57 9 21 150.0 2.0 28.0 spng
-58 10 22 150.0 2.0 29.0 spng
-59 11 23 150.0 2.0 28.0 spng
-60 12 24 150.0 2.0 28.0 spng
-61 13 25 150.0 2.0 29.0 spng
-62 14 26 150.0 2.0 28.0 spng
-63 15 27 150.0 2.0 28.0 spng
-64 16 28 150.0 2.0 29.0 spng
-65 17 29 150.0 2.0 28.0 spng
-66 18 30 150.0 2.0 28.0 spng
-67 19 31 150.0 2.0 29.0 spng
-68 20 32 150.0 2.0 28.0 spng
-69 21 33 150.0 2.0 28.0 spng
-70 22 34 150.0 2.0 29.0 spng
-71 23 35 150.0 2.0 28.0 spng
-72 24 36 150.0 2.0 28.0 spng
-73 25 37 150.0 2.0 29.0 spng
-74 26 38 150.0 2.0 28.0 spng
-75 27 39 150.0 2.0 28.0 spng
-76 28 40 150.0 2.0 29.0 spng
-77 29 41 150.0 2.0 28.0 spng
-78 30 42 150.0 2.0 28.0 spng
-79 31 43 150.0 2.0 29.0 spng
-80 32 44 150.0 2.0 28.0 spng
-81 33 45 150.0 2.0 28.0 spng
-82 34 46 150.0 2.0 29.0 spng
-83 35 47 150.0 2.0 28.0 spng
-84 36 48 150.0 2.0 28.0 spng
-85 1 14 150.0 2.0 35.0 spng
-86 2 15 150.0 2.0 35.0 spng
-87 3 16 150.0 2.0 34.0 spng
-88 4 17 150.0 2.0 35.0 spng
-89 5 18 150.0 2.0 35.0 spng
-90 6 19 150.0 2.0 34.0 spng
-91 7 20 150.0 2.0 35.0 spng
-92 8 21 150.0 2.0 35.0 spng
-93 9 22 150.0 2.0 34.0 spng
-94 10 23 150.0 2.0 35.0 spng
-95 11 24 150.0 2.0 35.0 spng
-96 12 13 150.0 2.0 34.0 spng
-97 13 26 150.0 2.0 46.0 spng
-98 14 27 150.0 2.0 45.0 spng
-99 15 28 150.0 2.0 45.0 spng
-100 16 29 150.0 2.0 46.0 spng
-101 17 30 150.0 2.0 45.0 spng
-102 18 31 150.0 2.0 45.0 spng
-103 19 32 150.0 2.0 45.0 spng
-104 20 33 150.0 2.0 45.0 spng
-105 21 34 150.0 2.0 45.0 spng
-106 22 35 150.0 2.0 46.0 spng
-107 23 36 150.0 2.0 45.0 spng
-108 24 25 150.0 2.0 45.0 spng
-109 25 38 150.0 2.0 58.0 spng
-110 26 39 150.0 2.0 58.0 spng
-111 27 40 150.0 2.0 58.0 spng
-112 28 41 150.0 2.0 58.0 spng
-113 29 42 150.0 2.0 58.0 spng
-114 30 43 150.0 2.0 58.0 spng
-115 31 44 150.0 2.0 58.0 spng
-116 32 45 150.0 2.0 58.0 spng
-117 33 46 150.0 2.0 58.0 spng
-118 34 47 150.0 2.0 58.0 spng
-119 35 48 150.0 2.0 58.0 spng
-120 36 37 150.0 2.0 58.0 spng
-121 1 24 150.0 2.0 35.0 spng
-122 2 13 150.0 2.0 34.0 spng
-123 3 14 150.0 2.0 35.0 spng
-124 4 15 150.0 2.0 35.0 spng
-125 5 16 150.0 2.0 34.0 spng
-126 6 17 150.0 2.0 35.0 spng
-127 7 18 150.0 2.0 35.0 spng
-128 8 19 150.0 2.0 34.0 spng
-129 9 20 150.0 2.0 35.0 spng
-130 10 21 150.0 2.0 35.0 spng
-131 11 22 150.0 2.0 34.0 spng
-132 12 23 150.0 2.0 35.0 spng
-133 13 36 150.0 2.0 46.0 spng
-134 14 25 150.0 2.0 45.0 spng
-135 15 26 150.0 2.0 45.0 spng
-136 16 27 150.0 2.0 46.0 spng
-137 17 28 150.0 2.0 45.0 spng
-138 18 29 150.0 2.0 45.0 spng
-139 19 30 150.0 2.0 46.0 spng
-140 20 31 150.0 2.0 45.0 spng
-141 21 32 150.0 2.0 45.0 spng
-142 22 33 150.0 2.0 46.0 spng
-143 23 34 150.0 2.0 45.0 spng
-144 24 35 150.0 2.0 45.0 spng
-145 25 48 150.0 2.0 58.0 spng
-146 26 37 150.0 2.0 58.0 spng
-147 27 38 150.0 2.0 58.0 spng
-148 28 39 150.0 2.0 58.0 spng
-149 29 40 150.0 2.0 58.0 spng
-150 30 41 150.0 2.0 58.0 spng
-151 31 42 150.0 2.0 58.0 spng
-152 32 43 150.0 2.0 58.0 spng
-153 33 44 150.0 2.0 58.0 spng
-154 34 45 150.0 2.0 58.0 spng
-155 35 46 150.0 2.0 58.0 spng
-156 36 47 150.0 2.0 58.0 spng
-157 10 4 150.0 2.0 52.331631 spng
-158 7 1 150.0 2.0 52.436772 spng
-159 12 6 150.0 2.0 54.680698 spng
-160 5 11 150.0 2.0 54.589379 spng
-161 9 3 150.0 2.0 54.451569 spng
-162 2 8 150.0 2.0 54.482231 spng
-163 45 11 150.0 2.0 101.408150 spng
-164 46 12 150.0 2.0 101.542452 spng
-165 47 1 150.0 2.0 101.963064 spng
-166 48 2 150.0 2.0 101.517329 spng
-167 37 3 150.0 2.0 101.603694 spng
-168 38 4 150.0 2.0 102.014031 spng
-169 39 5 150.0 2.0 101.547660 spng
-170 40 6 150.0 2.0 101.573762 spng
-171 41 7 150.0 2.0 101.897300 spng
-172 42 8 150.0 2.0 101.497982 spng
-173 43 9 150.0 2.0 101.870594 spng
-174 44 10 150.0 2.0 102.043753 spng
-175 45 11 150.0 2.0 101.408150 spng
-176 46 8 150.0 2.0 101.548938 spng
-177 47 10 150.0 2.0 90.645939 spng
-178 48 10 150.0 2.0 101.952119 spng
-179 37 11 150.0 2.0 101.552352 spng
-180 38 12 150.0 2.0 101.491447 spng
-181 39 1 150.0 2.0 101.971524 spng
-182 40 2 150.0 2.0 101.587400 spng
-183 41 3 150.0 2.0 101.519279 spng
-184 42 4 150.0 2.0 101.976181 spng
-185 43 5 150.0 2.0 101.714570 spng
-186 44 6 150.0 2.0 101.388747 spng
-187 45 7 150.0 2.0 101.773286 spng
-
-nodes> [ { 0 100 } swap set-node-vel ] each ;
-
-USING: threads ui ;
-
-: go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ;
-
-MAIN: go
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences threads math ui random
- springies springies.ui ;
-
-IN: springies.models.belt-tire
-
-: model ( -- )
-
-{ } clone >nodes
-{ } clone >springs
-0.008 >time-slice
-gravity on
-
-1 274.078806900597328 346.307117178664043 0 0 1 0.5 mass
-2 284.142891110742823 329.83402842231834 0 0 1 0.5 mass
-3 295.307158356938658 355.695013578746227 0 0 1 0.5 mass
-4 300.698527801927128 337.003548930923216 0 0 1 0.5 mass
-5 318.093036910029696 359.203044347904552 0 0 1 0.5 mass
-6 318.542098798246286 339.592403450546044 0 0 1 0.5 mass
-7 340.949296214486822 356.831259237330983 0 0 1 0.5 mass
-8 336.494524828869885 337.754019325244656 0 0 1 0.5 mass
-9 362.534986907234952 348.770558940029559 0 0 1 0.5 mass
-10 353.491265306914897 331.642140359094469 0 0 1 0.5 mass
-11 381.368850422101502 335.37878701564847 0 0 1 0.5 mass
-12 368.085531061140216 321.055018811315335 0 0 1 0.5 mass
-13 396.117634938806759 317.519287773537314 0 0 1 0.5 mass
-14 379.675208211408915 307.277961968837246 0 0 1 0.5 mass
-15 405.655157991023771 296.391903048606025 0 0 1 0.5 mass
-16 387.124676448692242 290.862310093183567 0 0 1 0.5 mass
-17 409.337178964708642 273.594658653786666 0 0 1 0.5 mass
-18 389.76569804010461 273.012494879567555 0 0 1 0.5 mass
-19 407.11203230551871 250.712646124396059 0 0 1 0.5 mass
-20 387.966228461346304 255.061007930370067 0 0 1 0.5 mass
-21 399.188308328902735 229.098161823607285 0 0 1 0.5 mass
-22 381.896222954111181 238.073977723246998 0 0 1 0.5 mass
-23 385.883224011375262 210.148208473511374 0 0 1 0.5 mass
-24 371.614761646970464 223.279700317395225 0 0 1 0.5 mass
-25 367.955378160003875 195.334436550727929 0 0 1 0.5 mass
-26 357.817091674528911 211.717360072075536 0 0 1 0.5 mass
-27 346.743525482831387 185.884698478394085 0 0 1 0.5 mass
-28 341.291169697238729 204.55711005838188 0 0 1 0.5 mass
-29 323.935265230381788 182.330460182137188 0 0 1 0.5 mass
-30 323.466187791799882 201.937076877994031 0 0 1 0.5 mass
-31 301.04141769400843 184.703602685435726 0 0 1 0.5 mass
-32 305.532794735419941 203.763859300438838 0 0 1 0.5 mass
-33 279.442362700896183 192.851996602076866 0 0 1 0.5 mass
-34 288.551113492738239 209.893932668644339 0 0 1 0.5 mass
-35 260.65997798024199 206.334196608396638 0 0 1 0.5 mass
-36 273.960657978745814 220.516324161880476 0 0 1 0.5 mass
-37 246.029909853431349 224.197583023911335 0 0 1 0.5 mass
-38 262.719165304227545 234.58428660123181 0 0 1 0.5 mass
-39 236.458142984593252 245.235572499606377 0 0 1 0.5 mass
-40 254.870454491934908 250.81914136861181 0 0 1 0.5 mass
-41 232.703447579492519 268.042376651164432 0 0 1 0.5 mass
-42 252.226120754560156 268.679895159358864 0 0 1 0.5 mass
-43 234.96767702938331 291.007702051922024 0 0 1 0.5 mass
-44 254.040589506795527 286.621843971355872 0 0 1 0.5 mass
-45 242.759412026738119 312.577114225657738 0 0 1 0.5 mass
-46 260.111088599530603 303.593264087352964 0 0 1 0.5 mass
-47 256.101782779606651 331.52509923420655 0 0 1 0.5 mass
-48 270.373388641766439 318.366074596339615 0 0 1 0.5 mass
-49 320.448537383965288 270.292364746678743 0 0 10 0.5 mass
-1 1 4 200 2 28.284271247461902 spng
-2 4 5 200 2 28.284271247461902 spng
-3 5 8 200 2 28.284271247461902 spng
-4 8 9 200 2 28.284271247461902 spng
-5 9 12 200 2 28.284271247461902 spng
-6 12 13 200 2 28.284271247461902 spng
-7 13 16 200 2 28.284271247461902 spng
-8 16 17 200 2 28.284271247461902 spng
-9 17 20 200 2 28.284271247461902 spng
-10 20 21 200 2 28.284271247461902 spng
-11 21 24 200 2 28.284271247461902 spng
-12 24 25 200 2 28.284271247461902 spng
-13 25 28 200 2 28.284271247461902 spng
-14 28 29 200 2 28.284271247461902 spng
-15 29 32 200 2 28.284271247461902 spng
-16 32 33 200 2 28.284271247461902 spng
-17 33 36 200 2 28.284271247461902 spng
-18 36 37 200 2 28.284271247461902 spng
-19 37 40 200 2 28.284271247461902 spng
-20 40 41 200 2 28.284271247461902 spng
-21 41 44 200 2 28.284271247461902 spng
-22 44 45 200 2 28.284271247461902 spng
-23 45 48 200 2 28.284271247461902 spng
-24 3 6 200 2 28.284271247461902 spng
-25 7 10 200 2 28.284271247461902 spng
-26 11 14 200 2 28.284271247461902 spng
-27 15 18 200 2 28.284271247461902 spng
-28 19 22 200 2 28.284271247461902 spng
-29 23 26 200 2 28.284271247461902 spng
-30 27 30 200 2 28.284271247461902 spng
-31 31 34 200 2 28.284271247461902 spng
-32 35 38 200 2 28.284271247461902 spng
-33 39 44 200 2 44.7213595499957961 spng
-34 39 42 200 2 28.284271247461902 spng
-35 43 46 200 2 28.284271247461902 spng
-36 47 46 200 2 28.284271247461902 spng
-37 43 42 200 2 28.284271247461902 spng
-38 39 38 200 2 28.284271247461902 spng
-39 35 34 200 2 28.284271247461902 spng
-40 2 3 200 2 28.284271247461902 spng
-41 6 7 200 2 28.284271247461902 spng
-42 10 11 200 2 28.284271247461902 spng
-43 14 15 200 2 28.284271247461902 spng
-44 18 19 200 2 28.284271247461902 spng
-45 22 23 200 2 28.284271247461902 spng
-46 26 27 200 2 28.284271247461902 spng
-47 30 31 200 2 28.284271247461902 spng
-48 1 6 200 2 44.7213595499957961 spng
-49 3 8 200 2 44.7213595499957961 spng
-50 5 10 200 2 44.7213595499957961 spng
-51 7 12 200 2 44.7213595499957961 spng
-52 9 14 200 2 44.7213595499957961 spng
-53 11 16 200 2 44.7213595499957961 spng
-54 13 18 200 2 44.7213595499957961 spng
-55 15 20 200 2 44.7213595499957961 spng
-56 17 22 200 2 44.7213595499957961 spng
-57 19 24 200 2 44.7213595499957961 spng
-58 21 26 200 2 44.7213595499957961 spng
-59 23 28 200 2 44.7213595499957961 spng
-60 25 30 200 2 44.7213595499957961 spng
-61 27 32 200 2 44.7213595499957961 spng
-62 29 34 200 2 44.7213595499957961 spng
-63 31 36 200 2 44.7213595499957961 spng
-64 33 38 200 2 44.7213595499957961 spng
-65 35 40 200 2 44.7213595499957961 spng
-66 37 42 200 2 44.7213595499957961 spng
-67 41 46 200 2 44.7213595499957961 spng
-68 43 48 200 2 44.7213595499957961 spng
-69 2 5 200 2 44.7213595499957961 spng
-70 4 7 200 2 44.7213595499957961 spng
-71 6 9 200 2 44.7213595499957961 spng
-72 8 11 200 2 44.7213595499957961 spng
-73 10 13 200 2 44.7213595499957961 spng
-74 12 15 200 2 44.7213595499957961 spng
-75 14 17 200 2 44.7213595499957961 spng
-76 16 19 200 2 44.7213595499957961 spng
-77 18 21 200 2 44.7213595499957961 spng
-78 20 23 200 2 44.7213595499957961 spng
-79 22 25 200 2 44.7213595499957961 spng
-80 24 27 200 2 44.7213595499957961 spng
-81 26 29 200 2 44.7213595499957961 spng
-82 28 31 200 2 44.7213595499957961 spng
-83 30 33 200 2 44.7213595499957961 spng
-84 32 35 200 2 44.7213595499957961 spng
-85 34 37 200 2 44.7213595499957961 spng
-86 36 39 200 2 44.7213595499957961 spng
-87 38 41 200 2 44.7213595499957961 spng
-88 40 43 200 2 44.7213595499957961 spng
-89 42 45 200 2 44.7213595499957961 spng
-90 44 47 200 2 44.7213595499957961 spng
-91 1 8 200 2 63.2455532033675851 spng
-92 3 10 200 2 63.2455532033675851 spng
-93 5 12 200 2 63.2455532033675851 spng
-94 7 14 200 2 63.2455532033675851 spng
-95 9 16 200 2 63.2455532033675851 spng
-96 11 18 200 2 63.2455532033675851 spng
-97 13 20 200 2 63.2455532033675851 spng
-98 15 22 200 2 63.2455532033675851 spng
-99 17 24 200 2 63.2455532033675851 spng
-100 19 26 200 2 63.2455532033675851 spng
-101 21 28 200 2 63.2455532033675851 spng
-102 23 30 200 2 63.2455532033675851 spng
-103 25 32 200 2 63.2455532033675851 spng
-104 27 34 200 2 63.2455532033675851 spng
-105 29 36 200 2 63.2455532033675851 spng
-106 31 38 200 2 63.2455532033675851 spng
-107 33 40 200 2 63.2455532033675851 spng
-108 35 42 200 2 63.2455532033675851 spng
-109 37 44 200 2 63.2455532033675851 spng
-110 39 46 200 2 63.2455532033675851 spng
-111 48 41 200 2 63.2455532033675851 spng
-112 2 7 200 2 63.2455532033675851 spng
-113 4 9 200 2 63.2455532033675851 spng
-114 6 11 200 2 63.2455532033675851 spng
-115 8 13 200 2 63.2455532033675851 spng
-116 10 15 200 2 63.2455532033675851 spng
-117 12 17 200 2 63.2455532033675851 spng
-118 14 19 200 2 63.2455532033675851 spng
-119 16 21 200 2 63.2455532033675851 spng
-120 18 23 200 2 63.2455532033675851 spng
-121 20 25 200 2 63.2455532033675851 spng
-122 22 27 200 2 63.2455532033675851 spng
-123 24 29 200 2 63.2455532033675851 spng
-124 26 31 200 2 63.2455532033675851 spng
-125 28 33 200 2 63.2455532033675851 spng
-126 30 35 200 2 63.2455532033675851 spng
-127 32 37 200 2 63.2455532033675851 spng
-128 34 39 200 2 63.2455532033675851 spng
-129 36 41 200 2 63.2455532033675851 spng
-130 38 43 200 2 63.2455532033675851 spng
-131 40 45 200 2 63.2455532033675851 spng
-132 42 47 200 2 63.2455532033675851 spng
-133 1 3 200 2 20 spng
-134 3 5 200 2 20 spng
-135 5 7 200 2 20 spng
-136 7 9 200 2 20 spng
-137 9 11 200 2 20 spng
-138 11 13 200 2 20 spng
-139 13 15 200 2 20 spng
-140 15 17 200 2 20 spng
-141 17 19 200 2 20 spng
-142 19 21 200 2 20 spng
-143 21 23 200 2 20 spng
-144 23 25 200 2 20 spng
-145 25 27 200 2 20 spng
-146 27 29 200 2 20 spng
-147 29 31 200 2 20 spng
-148 31 33 200 2 20 spng
-149 33 35 200 2 20 spng
-150 35 37 200 2 20 spng
-151 37 39 200 2 20 spng
-152 39 41 200 2 20 spng
-153 41 43 200 2 20 spng
-154 43 45 200 2 20 spng
-155 45 47 200 2 20 spng
-156 2 4 200 2 20 spng
-157 4 6 200 2 20 spng
-158 6 8 200 2 20 spng
-159 8 10 200 2 20 spng
-160 10 12 200 2 20 spng
-161 12 14 200 2 20 spng
-162 14 16 200 2 20 spng
-163 16 18 200 2 20 spng
-164 18 20 200 2 20 spng
-165 20 22 200 2 20 spng
-166 22 24 200 2 20 spng
-167 24 26 200 2 20 spng
-168 26 28 200 2 20 spng
-169 28 30 200 2 20 spng
-170 30 32 200 2 20 spng
-171 32 34 200 2 20 spng
-172 34 36 200 2 20 spng
-173 36 38 200 2 20 spng
-174 38 40 200 2 20 spng
-175 40 42 200 2 20 spng
-176 42 44 200 2 20 spng
-177 44 46 200 2 20 spng
-178 46 48 200 2 20 spng
-179 1 2 200 2 20 spng
-180 3 4 200 2 20 spng
-181 5 6 200 2 20 spng
-182 7 8 200 2 20 spng
-183 9 10 200 2 20 spng
-184 11 12 200 2 20 spng
-185 13 14 200 2 20 spng
-186 15 16 200 2 20 spng
-187 17 18 200 2 20 spng
-188 19 20 200 2 20 spng
-189 21 22 200 2 20 spng
-190 23 24 200 2 20 spng
-191 25 26 200 2 20 spng
-192 27 28 200 2 20 spng
-193 29 30 200 2 20 spng
-194 31 32 200 2 20 spng
-195 33 34 200 2 20 spng
-196 35 36 200 2 20 spng
-197 37 38 200 2 20 spng
-198 39 40 200 2 20 spng
-199 41 42 200 2 20 spng
-200 43 44 200 2 20 spng
-201 45 46 200 2 20 spng
-202 47 48 200 2 20 spng
-203 47 2 200 2 28.284271247461902 spng
-204 1 48 200 2 28.284271247461902 spng
-205 1 46 200 2 44.7213595499957961 spng
-206 1 44 200 2 63.2455532033675851 spng
-207 47 4 200 2 44.7213595499957961 spng
-208 48 3 200 2 44.7213595499957961 spng
-209 47 6 200 2 63.2455532033675851 spng
-210 48 5 200 2 63.2455532033675851 spng
-211 46 3 200 2 63.2455532033675851 spng
-212 45 4 200 2 63.2455532033675851 spng
-213 47 1 200 2 20 spng
-214 48 2 200 2 20 spng
-215 18 49 300 3 69.2603782836911677 spng
-216 49 20 300 3 69.050706006528273 spng
-217 22 49 300 3 69.3541635375988079 spng
-218 49 24 300 3 69.5269731830747872 spng
-219 26 49 300 3 69.6347614342147381 spng
-220 49 28 300 3 68.9492567037527948 spng
-221 30 49 300 3 68.2641926635040477 spng
-222 49 32 300 3 68.0661443009665419 spng
-223 34 49 300 3 68.4470598345904051 spng
-224 49 36 300 3 68.1175454637056106 spng
-225 38 49 300 3 67.6756972627545252 spng
-226 49 40 300 3 68.6221538571910514 spng
-227 42 49 300 3 68.1835757349231386 spng
-228 49 44 300 3 68.249542123006222 spng
-229 46 49 300 3 68.8767014308902503 spng
-230 49 48 300 3 69.4262198308391305 spng
-231 2 49 300 3 69.8927750200262068 spng
-232 49 4 300 3 69.5701085237043486 spng
-233 6 49 300 3 69.1809222257119103 spng
-234 8 49 300 3 69.2314957226839027 spng
-235 49 10 300 3 69.7782200976780445 spng
-236 12 49 300 3 69.5269731830747872 spng
-237 49 14 300 3 69.8927750200262068 spng
-238 16 49 300 3 69.8927750200262068 spng
-
-
-nodes> 200 random -100 + 100 2array [ swap set-node-vel ] curry each ;
-
-: go ( -- ) [ model ] go* ;
-
-MAIN: go
\ No newline at end of file
+++ /dev/null
-USING: tools.deploy.config ;
-V{
- { deploy-ui? t }
- { deploy-io 2 }
- { deploy-reflection 1 }
- { deploy-compiler? t }
- { deploy-math? t }
- { deploy-word-props? f }
- { deploy-word-defs? f }
- { deploy-c-types? f }
- { "stop-after-last-window?" t }
- { "bundle-name" "Belt Tire.app" }
-}
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences threads math math.vectors
- ui random springies springies.ui ;
-
-IN: springies.models.nifty
-
-: model ( -- )
-
-{ } clone >nodes
-{ } clone >springs
-0.007 >time-slice
-gravity off
-
-1 148.581450999999987 350.573888000000011 0 -7.75 1 0.1 mass
-2 168.564277000000004 351.402524000000028 0 -7.75 1 0.1 mass
-3 188.54710399999999 352.231158999999991 0 -7.75 1 0.1 mass
-4 208.529931000000005 353.059794000000011 0 -7.75 1 0.1 mass
-5 228.512757999999991 353.888428999999974 0 -7.75 1 0.1 mass
-6 248.495584000000008 354.717063999999993 0 -7.75 1 0.1 mass
-7 149.410086000000007 330.591061000000025 0 -7.75 1 0.1 mass
-8 150.238720999999998 310.608234999999979 0 -7.75 1 0.1 mass
-9 151.06735599999999 290.625407999999993 0 -7.75 1 0.1 mass
-10 151.895991000000009 270.642581000000007 0 -7.75 1 0.1 mass
-11 152.724626000000001 250.65975499999999 0 -7.75 1 0.1 mass
-12 172.707452999999987 251.48839000000001 0 -7.749999 1 0.1 mass
-13 192.690280000000001 252.317025000000001 0 -7.75 1 0.1 mass
-14 212.67310599999999 253.145659999999992 0 -7.75 1 0.1 mass
-15 232.655933000000005 253.974295000000012 0 -7.75 1 0.1 mass
-16 252.638759999999991 254.802930000000003 0 -7.75 1 0.1 mass
-17 251.810124999999999 274.78575699999999 0 -7.75 1 0.1 mass
-18 250.98148900000001 294.768583999999976 0 -7.75 1 0.1 mass
-19 249.324218999999999 334.734237000000007 0 -7.75 1 0.1 mass
-20 250.152853999999991 314.751410000000021 0 -7.75 1 0.1 mass
-1 1 2 200 1.5 20 spng
-2 2 3 200 1.5 20 spng
-3 3 4 200 1.5 20 spng
-4 4 5 200 1.5 20 spng
-5 5 6 200 1.5 20 spng
-6 6 19 200 1.5 20 spng
-7 19 20 200 1.5 20 spng
-8 20 18 200 1.5 20 spng
-9 18 17 200 1.5 20 spng
-10 17 16 200 1.5 20 spng
-11 16 15 200 1.5 20 spng
-12 15 14 200 1.5 20 spng
-13 14 13 200 1.5 20 spng
-14 13 12 200 1.5 20 spng
-15 12 11 200 1.5 20 spng
-16 11 10 200 1.5 20 spng
-17 10 9 200 1.5 20 spng
-18 9 8 200 1.5 20 spng
-19 8 7 200 1.5 20 spng
-20 7 1 200 1.5 20 spng
-21 1 19 200 1.5 101.98039 spng
-22 19 14 200 1.5 89.4427189999999968 spng
-23 14 8 200 1.5 84.8528139999999951 spng
-24 8 5 200 1.5 89.4427189999999968 spng
-25 5 16 200 1.5 101.98039 spng
-26 16 10 200 1.5 101.98039 spng
-27 10 3 200 1.5 89.4427189999999968 spng
-28 3 18 200 1.5 84.8528139999999951 spng
-29 18 12 200 1.5 89.4427189999999968 spng
-30 12 1 200 1.5 101.98039 spng
-31 2 20 200 1.5 89.4427189999999968 spng
-32 20 13 200 1.5 84.8528139999999951 spng
-33 13 7 200 1.5 89.4427189999999968 spng
-34 7 6 200 1.5 101.98039 spng
-35 6 15 200 1.5 101.98039 spng
-36 15 9 200 1.5 89.4427189999999968 spng
-37 9 4 200 1.5 84.8528139999999951 spng
-38 4 17 200 1.5 89.4427189999999968 spng
-39 17 11 200 1.5 101.98039 spng
-40 11 2 200 1.5 101.98039 spng
-
-nodes> 200 random -100 + 200 random -100 + 2array [ swap set-node-vel ] curry
-each ;
-
-: go ( -- ) [ model ] go* ;
-
-MAIN: go
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences threads math math.vectors
- ui random
- springies springies.ui ;
-
-IN: springies.models.urchin
-
-: model ( -- )
-
-{ } clone >nodes
-{ } clone >springs
-0.007 >time-slice
-gravity on
-
-1 507.296953 392.174236 -11.451186 -71.267273 1.0 1.0 mass
-2 514.879820 372.128025 11.950035 -70.858717 1.0 1.0 mass
-3 536.571268 364.423706 18.394466 -41.159445 1.0 1.0 mass
-4 554.886966 369.953895 15.173664 -11.009243 1.0 1.0 mass
-5 572.432935 379.927626 8.228103 -1.120846 1.0 1.0 mass
-6 585.774508 392.380791 5.443281 -8.186599 1.0 1.0 mass
-7 584.650543 411.934530 -15.582843 -24.911756 1.0 1.0 mass
-8 569.409148 424.155713 -24.100159 -42.285960 1.0 1.0 mass
-9 553.751996 434.663690 -26.069217 -41.610454 1.0 1.0 mass
-10 536.684374 444.915694 -30.702349 -45.021926 1.0 1.0 mass
-11 516.677286 435.936238 -33.128410 -60.977340 1.0 1.0 mass
-12 514.170680 414.649472 -24.471518 -64.104425 1.0 1.0 mass
-13 602.101547 478.298945 1.612646 -53.040881 1.0 1.0 mass
-14 637.0 427.598266 0.0 0.0 1.0 1.0 mass
-15 608.000171 350.425575 31.812856 23.456940 1.0 1.0 mass
-16 484.367809 332.414622 42.575378 -91.238351 1.0 1.0 mass
-17 480.857379 475.215663 -24.240991 -53.909049 1.0 1.0 mass
-18 548.580015 492.173168 -34.565312 -52.436468 1.0 1.0 mass
-19 578.155338 487.173526 22.544495 -71.920721 1.0 1.0 mass
-20 630.992588 379.333707 16.662115 37.873709 1.0 1.0 mass
-21 591.256916 324.817423 63.036114 27.988433 1.0 1.0 mass
-22 539.051461 311.597938 159.501014 -27.955219 1.0 1.0 mass
-23 448.396171 396.882674 -15.045910 -138.652372 1.0 1.0 mass
-24 448.194414 419.993896 -27.625008 -84.936708 1.0 1.0 mass
-1 1 2 200.0 3.0 20.0 spng
-2 2 3 200.0 3.0 20.0 spng
-3 3 4 200.0 3.0 20.0 spng
-4 4 5 200.0 3.0 20.0 spng
-5 5 6 200.0 3.0 20.0 spng
-6 6 7 200.0 3.0 20.0 spng
-7 7 8 200.0 3.0 20.0 spng
-8 8 9 200.0 3.0 20.0 spng
-9 9 10 200.0 3.0 20.0 spng
-10 10 11 200.0 3.0 20.0 spng
-11 11 12 200.0 3.0 20.0 spng
-12 1 3 200.0 3.0 40.0 spng
-13 2 4 200.0 3.0 40.0 spng
-14 3 5 200.0 3.0 40.0 spng
-15 4 6 200.0 3.0 40.0 spng
-16 6 8 200.0 3.0 40.0 spng
-17 7 9 200.0 3.0 40.0 spng
-18 8 10 200.0 3.0 40.0 spng
-19 9 11 200.0 3.0 40.0 spng
-20 10 12 200.0 3.0 40.0 spng
-21 12 1 200.0 3.0 21.0 spng
-22 12 2 200.0 3.0 41.0 spng
-23 11 1 200.0 3.0 41.0 spng
-24 6 12 200.0 3.0 72.681733 spng
-25 5 11 200.0 3.0 81.191259 spng
-26 10 4 200.0 3.0 76.026311 spng
-27 3 9 200.0 3.0 72.615425 spng
-28 8 2 200.0 3.0 74.966659 spng
-29 1 7 200.0 3.0 80.280757 spng
-30 17 11 200.0 3.0 55.036352 spng
-31 10 18 200.0 3.0 49.819675 spng
-32 19 9 200.0 3.0 54.918121 spng
-33 8 13 200.0 3.0 62.201286 spng
-34 14 7 200.0 3.0 58.600341 spng
-35 6 20 200.0 3.0 46.400431 spng
-36 15 5 200.0 3.0 44.045431 spng
-37 4 21 200.0 3.0 57.454330 spng
-38 22 3 200.0 3.0 53.823787 spng
-39 2 16 200.0 3.0 51.039201 spng
-40 23 1 200.0 3.0 58.668561 spng
-41 12 24 200.0 3.0 64.404969 spng
-42 24 11 200.0 3.0 71.217975 spng
-43 17 12 200.0 3.0 65.0 spng
-44 11 18 200.0 3.0 60.745370 spng
-45 18 9 200.0 3.0 60.406953 spng
-46 9 13 200.0 3.0 67.779053 spng
-47 13 7 200.0 3.0 66.708320 spng
-48 7 20 200.0 3.0 55.659680 spng
-49 20 5 200.0 3.0 60.0 spng
-50 5 21 200.0 3.0 61.846584 spng
-51 21 3 200.0 3.0 64.031242 spng
-52 3 16 200.0 3.0 63.568860 spng
-53 16 1 200.0 3.0 59.774577 spng
-54 1 24 200.0 3.0 65.802736 spng
-55 17 10 200.0 3.0 64.845971 spng
-56 10 19 200.0 3.0 58.249464 spng
-57 19 8 200.0 3.0 67.268120 spng
-58 8 14 200.0 3.0 67.268120 spng
-59 14 6 200.0 3.0 64.629715 spng
-60 6 15 200.0 3.0 50.089919 spng
-61 15 4 200.0 3.0 56.320511 spng
-62 4 22 200.0 3.0 60.728906 spng
-63 22 2 200.0 3.0 61.032778 spng
-64 2 23 200.0 3.0 66.528190 spng
-65 23 12 200.0 3.0 72.277244 spng
-
-nodes>
- 75 random -75 + 0 2array [ over node-vel v+ swap set-node-vel ]
-curry each
-
-;
-
-: go ( -- ) [ model ] go* ;
-
-MAIN: go
\ No newline at end of file
+++ /dev/null
-
-USING: kernel combinators sequences arrays math math.vectors
- generalizations vars accessors math.physics.vel ;
-
-IN: springies
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: scalar-projection ( a b -- n ) [ v. ] [ nip norm ] 2bi / ;
-
-: vector-projection ( a b -- vec )
- [ nip normalize ] [ scalar-projection ] 2bi v*n ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: nodes
-VAR: springs
-VAR: time-slice
-VAR: world-size
-
-: world-width ( -- width ) world-size> first ;
-
-: world-height ( -- height ) world-size> second ;
-
-VAR: gravity
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! node
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: node < vel mass elas force ;
-
-C: <node> node
-
-: node-vel ( node -- vel ) vel>> ;
-
-: set-node-vel ( vel node -- ) swap >>vel drop ;
-
-: pos-x ( node -- x ) pos>> first ;
-: pos-y ( node -- y ) pos>> second ;
-: vel-x ( node -- y ) vel>> first ;
-: vel-y ( node -- y ) vel>> second ;
-
-: >>pos-x ( node x -- node ) over pos>> set-first ;
-: >>pos-y ( node y -- node ) over pos>> set-second ;
-: >>vel-x ( node x -- node ) over vel>> set-first ;
-: >>vel-y ( node y -- node ) over vel>> set-second ;
-
-: apply-force ( node vec -- ) over force>> v+ >>force drop ;
-
-: reset-force ( node -- node ) 0 0 2array >>force ;
-
-: node-id ( id -- node ) 1- nodes> nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! spring
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: spring rest-length k damp node-a node-b ;
-
-C: <spring> spring
-
-: end-points ( spring -- b-pos a-pos )
- [ node-b>> pos>> ] [ node-a>> pos>> ] bi ;
-
-: spring-length ( spring -- length ) end-points v- norm ;
-
-: stretch-length ( spring -- length )
- [ spring-length ] [ rest-length>> ] bi - ;
-
-: dir ( spring -- vec ) end-points v- normalize ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Hooke
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-! F = -kx
-!
-! k :: spring constant
-! x :: distance stretched beyond rest length
-!
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: hooke-force-mag ( spring -- mag ) [ k>> ] [ stretch-length ] bi * ;
-
-: hooke-force ( spring -- force ) [ dir ] [ hooke-force-mag ] bi v*n ;
-
-: hooke-forces ( spring -- a b ) hooke-force dup vneg ;
-
-: act-on-nodes-hooke ( spring -- )
- [ node-a>> ] [ node-b>> ] [ ] tri hooke-forces swapd
- apply-force
- apply-force ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! damping
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-! F = -bv
-!
-! b :: Damping constant
-! v :: Velocity
-!
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : damping-force-a ( spring -- vec )
-! [ spring-node-a node-vel ] [ spring-damp ] bi v*n vneg ;
-
-! : damping-force-b ( spring -- vec )
-! [ spring-node-b node-vel ] [ spring-damp ] bi v*n vneg ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: relative-velocity-a ( spring -- vel )
- [ node-a>> vel>> ] [ node-b>> vel>> ] bi v- ;
-
-: unit-vec-b->a ( spring -- vec )
- [ node-a>> pos>> ] [ node-b>> pos>> ] bi v- ;
-
-: relative-velocity-along-spring-a ( spring -- vel )
- [ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ;
-
-: damping-force-a ( spring -- vec )
- [ relative-velocity-along-spring-a ] [ damp>> ] bi v*n vneg ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: relative-velocity-b ( spring -- vel )
- [ node-b>> vel>> ] [ node-a>> vel>> ] bi v- ;
-
-: unit-vec-a->b ( spring -- vec )
- [ node-b>> pos>> ] [ node-a>> pos>> ] bi v- ;
-
-: relative-velocity-along-spring-b ( spring -- vel )
- [ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ;
-
-: damping-force-b ( spring -- vec )
- [ relative-velocity-along-spring-b ] [ damp>> ] bi v*n vneg ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: act-on-nodes-damping ( spring -- )
- dup
- [ node-a>> ] [ damping-force-a ] bi apply-force
- [ node-b>> ] [ damping-force-b ] bi apply-force ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: below? ( node -- ? ) pos-y 0 < ;
-
-: above? ( node -- ? ) pos-y world-height >= ;
-
-: beyond-left? ( node -- ? ) pos-x 0 < ;
-
-: beyond-right? ( node -- ? ) pos-x world-width >= ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bounce-top ( node -- )
- world-height 1- >>pos-y
- dup [ vel-y ] [ elas>> ] bi * neg >>vel-y
- drop ;
-
-: bounce-bottom ( node -- )
- 0 >>pos-y
- dup [ vel-y ] [ elas>> ] bi * neg >>vel-y
- drop ;
-
-: bounce-left ( node -- )
- 0 >>pos-x
- dup [ vel-x ] [ elas>> ] bi * neg >>vel-x
- drop ;
-
-: bounce-right ( node -- )
- world-width 1- >>pos-x
- dup [ vel-x ] [ elas>> ] bi * neg >>vel-x
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: handle-bounce ( node -- )
- { { [ dup above? ] [ bounce-top ] }
- { [ dup below? ] [ bounce-bottom ] }
- { [ dup beyond-left? ] [ bounce-left ] }
- { [ dup beyond-right? ] [ bounce-right ] }
- { [ t ] [ drop ] } }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: act-on-nodes ( spring -- )
- dup
- act-on-nodes-hooke
- act-on-nodes-damping ;
-
-! : act-on-nodes ( spring -- ) act-on-nodes-hooke ;
-
-: loop-over-springs ( -- ) springs> [ act-on-nodes ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: apply-gravity ( node -- ) { 0 -9.8 } apply-force ;
-
-: do-gravity ( -- ) gravity> [ nodes> [ apply-gravity ] each ] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! F = ma
-
-: calc-acceleration ( node -- vec ) [ force>> ] [ mass>> ] bi v/n ;
-
-: new-vel ( node -- vel )
- [ vel>> ] [ calc-acceleration time-slice> v*n ] bi v+ ;
-
-: new-pos ( node -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ;
-
-: iterate-node ( node -- )
- dup new-pos >>pos
- dup new-vel >>vel
- reset-force
- handle-bounce ;
-
-: iterate-nodes ( -- ) nodes> [ iterate-node ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: iterate-system ( -- ) do-gravity loop-over-springs iterate-nodes ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Reading xspringies data files
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: mass ( id x y x-vel y-vel mass elas -- )
- node new
- swap >>elas
- swap >>mass
- -rot 2array >>vel
- -rot 2array >>pos
- 0 0 2array >>force
- nodes> swap suffix >nodes
- drop ;
-
-: spng ( id id-a id-b k damp rest-length -- )
- spring new
- swap >>rest-length
- swap >>damp
- swap >>k
- swap node-id >>node-b
- swap node-id >>node-a
- springs> swap suffix >springs
- drop ;
\ No newline at end of file
+++ /dev/null
-Mass and spring simulation (inspired by xspringies)
+++ /dev/null
-simulation
-physics
-demos
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces threads sequences math math.vectors
- opengl.gl opengl colors ui ui.gadgets ui.gadgets.slate
- fry rewrite-closures vars springies accessors math.geometry.rect ;
-
-IN: springies.ui
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: draw-node ( node -- ) pos>> { -5 -5 } v+ [ { 10 10 } gl-rect ] with-translation ;
-
-: draw-spring ( spring -- )
- [ node-a>> pos>> ] [ node-b>> pos>> ] bi gl-line ;
-
-: draw-nodes ( -- ) nodes> [ draw-node ] each ;
-
-: draw-springs ( -- ) springs> [ draw-spring ] each ;
-
-: set-projection ( -- )
- GL_PROJECTION glMatrixMode
- glLoadIdentity
- 0 world-width 1- 0 world-height 1- -1 1 glOrtho
- GL_MODELVIEW glMatrixMode
- glLoadIdentity ;
-
-! : display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
-
-: display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: slate
-
-VAR: loop
-
-: update-world-size ( -- ) slate> rect-dim >world-size ;
-
-: refresh-slate ( -- ) slate> relayout-1 ;
-
-DEFER: maybe-loop
-
-: run ( -- )
- update-world-size
- iterate-system
- refresh-slate
- yield
- maybe-loop ;
-
-: maybe-loop ( -- ) loop> [ run ] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: springies-window* ( -- )
-
- C[ display ] <slate>
- { 800 600 } >>pdim
- C[ { 500 500 } >world-size loop on [ run ] in-thread ] >>graft
- C[ loop off ] >>ungraft
- [ >slate ] [ "Springies" open-window ] bi ;
-
-: springies-window ( -- ) [ [ springies-window* ] with-scope ] with-ui ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: go* ( quot -- ) '[ [ springies-window* 1000 sleep @ ] with-scope ] with-ui ;
! Copyright (C) 2006, 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators kernel math math.vectors namespaces opengl opengl.gl sequences tetris.board tetris.game tetris.piece ui.render tetris.tetromino ui.gadgets ;
+USING: accessors arrays combinators kernel math math.vectors
+namespaces opengl opengl.gl sequences tetris.board tetris.game
+tetris.piece ui.render tetris.tetromino ui.gadgets colors ;
IN: tetris.gl
#! OpenGL rendering for tetris
: draw-next-piece ( piece -- )
dup tetromino>> colour>>
- clone 0.2 >>alpha gl-color draw-piece-blocks ;
+ >rgba-components drop 0.2 <rgba> gl-color draw-piece-blocks ;
! TODO: move implementation specific stuff into tetris-board
: (draw-row) ( x y row -- )
! Copyright (C) 2006, 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays namespaces sequences math math.order
-math.vectors colors random ;
+math.vectors colors colors.constants random ;
IN: tetris.tetromino
TUPLE: tetromino states colour ;
{ 0 2 }
{ 0 3 }
}
- } cyan
+ } COLOR: cyan
] [
{
{ { 1 0 }
{ 0 1 } { 1 1 }
{ 1 2 }
}
- } purple
+ } COLOR: purple
] [
{ { { 0 0 } { 1 0 }
{ 0 1 } { 1 1 } }
- } yellow
+ } COLOR: yellow
] [
{
{ { 0 0 } { 1 0 } { 2 0 }
{ 0 1 }
{ 0 2 } { 1 2 }
}
- } orange
+ } COLOR: orange
] [
{
{ { 0 0 } { 1 0 } { 2 0 }
{ 0 1 }
{ 0 2 }
}
- } blue
+ } COLOR: blue
] [
{
{ { 1 0 } { 2 0 }
{ 0 1 } { 1 1 }
{ 1 2 }
}
- } green
+ } COLOR: green
] [
{
{
{ 0 1 } { 1 1 }
{ 0 2 }
}
- } red
+ } COLOR: red
]
-} [ call <tetromino> ] map tetrominoes set-global
+} [ first2 <tetromino> ] map tetrominoes set-global
: random-tetromino ( -- tetromino )
tetrominoes get random ;
+++ /dev/null
-
-USING: kernel accessors locals namespaces sequences threads
- math math.order math.vectors
- calendar
- colors opengl ui ui.gadgets ui.gestures ui.render
- circular
- processing.shapes ;
-
-IN: trails
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Example 33-15 from the Processing book
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Return the mouse location relative to the current gadget
-
-: mouse ( -- point ) hand-loc get hand-gadget get screen-loc v- ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: point-list ( n -- seq ) [ drop { 0 0 } ] map <circular> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: percent->radius ( percent -- radius ) neg 1 + 25 * 5 max ;
-
-: dot ( pos percent -- ) percent->radius circle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <trails-gadget> < gadget paused points ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: iterate-system ( GADGET -- )
-
- ! Add a valid point if the mouse is in the gadget
- ! Otherwise, add an "invisible" point
-
- hand-gadget get GADGET =
- [ mouse GADGET points>> push-circular ]
- [ { -10 -10 } GADGET points>> push-circular ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: start-trails-thread ( GADGET -- )
- GADGET f >>paused drop
- [
- [
- GADGET paused>>
- [ f ]
- [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
- if
- ]
- loop
- ]
- in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: <trails-gadget> pref-dim* ( <trails-gadget> -- dim ) drop { 500 500 } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: each-percent ( seq quot -- )
- [
- dup length
- dup [ / ] curry
- [ 1+ ] prepose
- ] dip compose
- 2each ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <trails-gadget> draw-gadget* ( GADGET -- )
- origin get
- [
- T{ rgba f 1 1 1 0.4 } \ fill-color set ! White, with some transparency
- T{ rgba f 0 0 0 0 } \ stroke-color set ! no stroke
-
- black gl-clear
-
- GADGET points>> [ dot ] each-percent
- ]
- with-translation ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: trails-gadget ( -- <trails-gadget> )
-
- <trails-gadget> new-gadget
-
- 300 point-list >>points
-
- t >>clipped?
-
- dup start-trails-thread ;
-
-: trails-window ( -- ) [ trails-gadget "Trails" open-window ] with-ui ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: trails-window
\ No newline at end of file
+++ /dev/null
-
-USING: kernel combinators sequences opengl.gl
- ui.render ui.gadgets ui.gadgets.slate
- accessors ;
-
-IN: ui.gadgets.cartesian
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: cartesian < slate x-min x-max y-min y-max z-min z-max perspective ;
-
-: init-cartesian ( cartesian -- cartesian )
- init-slate
- -10 >>x-min
- 10 >>x-max
- -10 >>y-min
- 10 >>y-max
- -1 >>z-min
- 1 >>z-max ;
-
-: <cartesian> ( -- cartesian ) cartesian new init-cartesian ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: cartesian establish-coordinate-system ( cartesian -- cartesian )
- dup
- {
- [ x-min>> ] [ x-max>> ]
- [ y-min>> ] [ y-max>> ]
- [ z-min>> ] [ z-max>> ]
- }
- cleave
- glOrtho ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: x-range ( cartesian range -- cartesian ) first2 [ >>x-min ] [ >>x-max ] bi* ;
-: y-range ( cartesian range -- cartesian ) first2 [ >>y-min ] [ >>y-max ] bi* ;
-: z-range ( cartesian range -- cartesian ) first2 [ >>z-min ] [ >>z-max ] bi* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-! Copyright (C) 2009 Eduardo Cavazos
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax multiline ;
-IN: ui.gadgets.slate
-
-ARTICLE: "ui.gadgets.slate" "Slate gadget"
-{ $description "A gadget with an 'action' slot which should be set to a callable."}
-{ $heading "Example" }
-{ $code <" USING: processing.shapes ui.gadgets.slate ui.gadgets.panes ;
-[ { { 10 10 } { 50 30 } { 10 50 } } polygon fill-mode ] <slate>
-gadget."> } ;
-
-ABOUT: "ui.gadgets.slate"
+++ /dev/null
-! Copyright (C) 2009 Eduardo Cavazos
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces opengl ui.render ui.gadgets accessors ;
-
-IN: ui.gadgets.slate
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: slate < gadget action pdim graft ungraft ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-slate ( slate -- slate )
- init-gadget
- [ ] >>action
- { 200 200 } >>pdim
- [ ] >>graft
- [ ] >>ungraft ;
-
-: <slate> ( action -- slate )
- slate new
- init-slate
- swap >>action ;
-
-M: slate pref-dim* ( slate -- dim ) pdim>> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: combinators arrays sequences math math.geometry
- opengl.gl ui.gadgets.worlds ;
-
-: screen-y* ( gadget -- loc )
- {
- [ find-world height ]
- [ screen-loc second ]
- [ height ]
- }
- cleave
- + - ;
-
-: screen-loc* ( gadget -- loc )
- {
- [ screen-loc first ]
- [ screen-y* ]
- }
- cleave
- 2array ;
-
-: setup-viewport ( gadget -- gadget )
- dup
- {
- [ screen-loc* ]
- [ dim>> ]
- }
- cleave
- gl-viewport ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: default-coordinate-system ( gadget -- gadget )
- dup
- {
- [ drop 0 ]
- [ width 1 - ]
- [ height 1 - ]
- [ drop 0 ]
- }
- cleave
- -1 1
- glOrtho ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate graft* ( slate -- ) graft>> call ;
-M: slate ungraft* ( slate -- ) ungraft>> call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: establish-coordinate-system ( gadget -- gadget )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate establish-coordinate-system ( slate -- slate )
- default-coordinate-system ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: draw-slate ( slate -- slate )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate draw-slate ( slate -- slate ) dup action>> call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate draw-gadget* ( slate -- )
-
- GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity
-
- establish-coordinate-system
-
- GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity
-
- setup-viewport
-
- draw-slate
-
- GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity
- GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity
-
- dup
- find-world
- ! The world coordinate system is a little wacky:
- dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho
- setup-viewport
- drop
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+++ /dev/null
-William Schlieper
\ No newline at end of file
+++ /dev/null
-Tabbed windows
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: accessors kernel fry math math.vectors sequences arrays vectors assocs\r
- hashtables models models.range models.product combinators\r
- ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs\r
- ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;\r
-\r
-IN: ui.gadgets.tabs\r
-\r
-TUPLE: tabbed < frame names toggler content ;\r
-\r
-DEFER: (del-page)\r
-\r
-:: add-toggle ( n name model toggler -- )\r
- <frame>\r
- n name toggler parent>> '[ drop _ _ _ (del-page) ] "X" swap <bevel-button>\r
- @right grid-add\r
- n model name <toggle-button> @center grid-add\r
- toggler swap add-gadget drop ;\r
-\r
-: redo-toggler ( tabbed -- )\r
- [ names>> ] [ model>> ] [ toggler>> ] tri\r
- [ clear-gadget ] keep\r
- [ [ length ] keep ] 2dip\r
- '[ _ _ add-toggle ] 2each ;\r
-\r
-: refresh-book ( tabbed -- )\r
- model>> [ ] change-model ;\r
-\r
-: (del-page) ( n name tabbed -- )\r
- { [ [ remove ] change-names redo-toggler ]\r
- [ dupd [ names>> length ] [ model>> ] bi\r
- [ [ = ] keep swap [ 1- ] when\r
- [ < ] keep swap [ 1- ] when ] change-model ]\r
- [ content>> nth-gadget unparent ]\r
- [ refresh-book ]\r
- } cleave ;\r
-\r
-: add-page ( page name tabbed -- )\r
- [ names>> push ] 2keep\r
- [ [ names>> length 1 - swap ]\r
- [ model>> ]\r
- [ toggler>> ] tri add-toggle ]\r
- [ content>> swap add-gadget drop ]\r
- [ refresh-book ] tri ;\r
-\r
-: del-page ( name tabbed -- )\r
- [ names>> index ] 2keep (del-page) ;\r
-\r
-: new-tabbed ( assoc class -- tabbed )\r
- new-frame\r
- 0 <model> >>model\r
- <pile> 1 >>fill >>toggler\r
- dup toggler>> @left grid-add\r
- swap\r
- [ keys >vector >>names ]\r
- [ values over model>> <book> >>content dup content>> @center grid-add ]\r
- bi\r
- dup redo-toggler ;\r
- \r
-: <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;\r
--- /dev/null
+
+USING: accessors arrays assocs calendar colors
+combinators.short-circuit help.markup help.syntax kernel locals
+math math.functions math.matrices math.order math.parser
+math.trig math.vectors opengl opengl.demo-support opengl.gl
+sbufs sequences strings threads ui.gadgets ui.gadgets.worlds
+ui.gestures ui.render ui.tools.workspace ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IN: L-system
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <turtle> pos ori angle length thickness color vertices saved ;
+
+DEFER: default-L-parser-values
+
+: reset-turtle ( turtle -- turtle )
+ { 0 0 0 } clone >>pos
+ 3 identity-matrix >>ori
+ V{ } clone >>vertices
+ V{ } clone >>saved
+
+ default-L-parser-values ;
+
+: turtle ( -- turtle ) <turtle> new reset-turtle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: step-turtle ( TURTLE LENGTH -- turtle )
+
+ TURTLE
+ TURTLE pos>> TURTLE ori>> { 0 0 LENGTH } m.v v+
+ >>pos ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: Rx ( ANGLE -- Rx )
+
+ [let | ANGLE [ ANGLE deg>rad ] |
+
+ [let | A [ ANGLE cos ]
+ B [ ANGLE sin neg ]
+ C [ ANGLE sin ]
+ D [ ANGLE cos ] |
+
+ { { 1 0 0 }
+ { 0 A B }
+ { 0 C D } }
+
+ ] ] ;
+
+:: Ry ( ANGLE -- Ry )
+
+ [let | ANGLE [ ANGLE deg>rad ] |
+
+ [let | A [ ANGLE cos ]
+ B [ ANGLE sin ]
+ C [ ANGLE sin neg ]
+ D [ ANGLE cos ] |
+
+ { { A 0 B }
+ { 0 1 0 }
+ { C 0 D } }
+
+ ] ] ;
+
+:: Rz ( ANGLE -- Rz )
+
+ [let | ANGLE [ ANGLE deg>rad ] |
+
+ [let | A [ ANGLE cos ]
+ B [ ANGLE sin neg ]
+ C [ ANGLE sin ]
+ D [ ANGLE cos ] |
+
+ { { A B 0 }
+ { C D 0 }
+ { 0 0 1 } }
+
+ ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: apply-rotation ( TURTLE ROTATION -- turtle )
+
+ TURTLE TURTLE ori>> ROTATION m. >>ori ;
+
+: rotate-x ( turtle angle -- turtle ) Rx apply-rotation ;
+: rotate-y ( turtle angle -- turtle ) Ry apply-rotation ;
+: rotate-z ( turtle angle -- turtle ) Rz apply-rotation ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pitch-up ( turtle angle -- turtle ) neg rotate-x ;
+: pitch-down ( turtle angle -- turtle ) rotate-x ;
+
+: turn-left ( turtle angle -- turtle ) rotate-y ;
+: turn-right ( turtle angle -- turtle ) neg rotate-y ;
+
+: roll-left ( turtle angle -- turtle ) neg rotate-z ;
+: roll-right ( turtle angle -- turtle ) rotate-z ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: V ( -- V ) { 0 1 0 } ;
+
+: X ( turtle -- 3array ) ori>> [ first ] map ;
+: Y ( turtle -- 3array ) ori>> [ second ] map ;
+: Z ( turtle -- 3array ) ori>> [ third ] map ;
+
+: set-X ( turtle seq -- turtle ) over ori>> [ set-first ] 2each ;
+: set-Y ( turtle seq -- turtle ) over ori>> [ set-second ] 2each ;
+: set-Z ( turtle seq -- turtle ) over ori>> [ set-third ] 2each ;
+
+:: roll-until-horizontal ( TURTLE -- turtle )
+
+ TURTLE
+
+ V TURTLE Z cross normalize set-X
+
+ TURTLE Z TURTLE X cross normalize set-Y ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: strafe-up ( TURTLE LENGTH -- turtle )
+ TURTLE 90 pitch-up LENGTH step-turtle 90 pitch-down ;
+
+:: strafe-down ( TURTLE LENGTH -- turtle )
+ TURTLE 90 pitch-down LENGTH step-turtle 90 pitch-up ;
+
+:: strafe-left ( TURTLE LENGTH -- turtle )
+ TURTLE 90 turn-left LENGTH step-turtle 90 turn-right ;
+
+:: strafe-right ( TURTLE LENGTH -- turtle )
+ TURTLE 90 turn-right LENGTH step-turtle 90 turn-left ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: polygon ( vertices -- ) GL_POLYGON glBegin [ first3 glVertex3d ] each glEnd ;
+
+: start-polygon ( turtle -- turtle ) dup vertices>> delete-all ;
+
+: finish-polygon ( turtle -- turtle ) dup vertices>> polygon ;
+
+: polygon-vertex ( turtle -- turtle ) dup [ pos>> ] [ vertices>> ] bi push ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: record-vertex ( turtle -- turtle ) dup pos>> first3 glVertex3d ;
+
+: draw-forward ( turtle length -- turtle )
+ GL_LINES glBegin [ record-vertex ] dip step-turtle record-vertex glEnd ;
+
+: move-forward ( turtle length -- turtle ) step-turtle polygon-vertex ;
+
+: sneak-forward ( turtle length -- turtle ) step-turtle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: scale-length ( turtle m -- turtle ) over length>> * >>length ;
+: scale-angle ( turtle m -- turtle ) over angle>> * >>angle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: set-thickness ( turtle i -- turtle ) dup glLineWidth >>thickness ;
+
+: scale-thickness ( turtle m -- turtle )
+ over thickness>> * 0.5 max set-thickness ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: color-table ( -- colors )
+ {
+ T{ rgba f 0 0 0 1 } ! black
+ T{ rgba f 0.5 0.5 0.5 1 } ! grey
+ T{ rgba f 1 0 0 1 } ! red
+ T{ rgba f 1 1 0 1 } ! yellow
+ T{ rgba f 0 1 0 1 } ! green
+ T{ rgba f 0.25 0.88 0.82 1 } ! turquoise
+ T{ rgba f 0 0 1 1 } ! blue
+ T{ rgba f 0.63 0.13 0.94 1 } ! purple
+ T{ rgba f 0.00 0.50 0.00 1 } ! dark green
+ T{ rgba f 0.00 0.82 0.82 1 } ! dark turquoise
+ T{ rgba f 0.00 0.00 0.50 1 } ! dark blue
+ T{ rgba f 0.58 0.00 0.82 1 } ! dark purple
+ T{ rgba f 0.50 0.00 0.00 1 } ! dark red
+ T{ rgba f 0.25 0.25 0.25 1 } ! dark grey
+ T{ rgba f 0.75 0.75 0.75 1 } ! medium grey
+ T{ rgba f 1 1 1 1 } ! white
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : material-color ( color -- )
+! GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ;
+
+: material-color ( color -- )
+ GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot color>raw 4array gl-material ;
+
+: set-color ( turtle i -- turtle )
+ dup color-table nth dup gl-color material-color >>color ;
+
+: inc-color ( turtle -- turtle ) dup color>> 1 + set-color ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: save-turtle ( turtle -- turtle ) dup clone over saved>> push ;
+
+: restore-turtle ( turtle -- turtle ) saved>> pop dup color>> set-color ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: default-L-parser-values ( turtle -- turtle )
+ 1 >>length 45 >>angle 1 >>thickness 2 >>color ;
+
+: L-parser-dialect ( -- commands )
+
+ {
+ { "+" [ dup angle>> turn-left ] }
+ { "-" [ dup angle>> turn-right ] }
+ { "&" [ dup angle>> pitch-down ] }
+ { "^" [ dup angle>> pitch-up ] }
+ { "<" [ dup angle>> roll-left ] }
+ { ">" [ dup angle>> roll-right ] }
+
+ { "|" [ 180.0 rotate-y ] }
+ { "%" [ 180.0 rotate-z ] }
+ { "$" [ roll-until-horizontal ] }
+
+ { "F" [ dup length>> draw-forward ] }
+ { "Z" [ dup length>> 2 / draw-forward ] }
+ { "f" [ dup length>> move-forward ] }
+ { "z" [ dup length>> 2 / move-forward ] }
+ { "g" [ dup length>> sneak-forward ] }
+ { "." [ polygon-vertex ] }
+
+ { "[" [ save-turtle ] }
+ { "]" [ restore-turtle ] }
+
+ { "{" [ start-polygon ] }
+ { "}" [ finish-polygon ] }
+
+ { "/" [ 1.1 scale-length ] } ! double quote command in lparser
+ { "'" [ 0.9 scale-length ] }
+ { ";" [ 1.1 scale-angle ] }
+ { ":" [ 0.9 scale-angle ] }
+ { "?" [ 1.4 scale-thickness ] }
+ { "!" [ 0.7 scale-thickness ] }
+
+ { "c" [ dup color>> 1 + color-table length mod set-color ] }
+
+ }
+ ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <L-system> < gadget
+ camera display-list pedestal paused
+ turtle-values
+ commands axiom rules string ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-system ( GADGET -- ) GADGET pedestal>> 0.5 + GADGET (>>pedestal) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-rotation-thread ( GADGET -- )
+ GADGET f >>paused drop
+ [
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
+ if
+ ]
+ loop
+ ]
+ in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: open-paren ( -- ch ) CHAR: ( ;
+: close-paren ( -- ch ) CHAR: ) ;
+
+: open-paren? ( obj -- ? ) open-paren = ;
+: close-paren? ( obj -- ? ) close-paren = ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: read-instruction ( STRING -- next rest )
+
+ { [ STRING length 1 > ] [ STRING second open-paren? ] } 0&&
+ [ STRING close-paren STRING index 1 + cut ]
+ [ STRING 1 cut ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-string-loop ( STRING RULES ACCUM -- )
+ STRING empty? not
+ [
+ STRING read-instruction
+
+ [let | REST [ ] NEXT [ ] |
+
+ NEXT 1 head RULES at NEXT or ACCUM push-all
+
+ REST RULES ACCUM iterate-string-loop ]
+ ]
+ when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-string ( STRING RULES -- string )
+
+ [let | ACCUM [ STRING length 10 * <sbuf> ] |
+
+ STRING RULES ACCUM iterate-string-loop
+
+ ACCUM >string ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: interpret-string ( STRING COMMANDS -- )
+
+ STRING empty? not
+ [
+ STRING read-instruction
+
+ [let | REST [ ] NEXT [ ] |
+
+ [let | COMMAND [ NEXT 1 head COMMANDS at ] |
+
+ COMMAND
+ [
+ NEXT length 1 =
+ [ COMMAND call ]
+ [
+ NEXT 2 tail 1 head* string>number
+ COMMAND 1 tail*
+ call
+ ]
+ if
+ ]
+ when ]
+
+ REST COMMANDS interpret-string ]
+ ]
+ when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-L-system-string ( L-SYSTEM -- )
+ L-SYSTEM string>> L-SYSTEM axiom>> or
+ L-SYSTEM rules>>
+ iterate-string
+ L-SYSTEM (>>string) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: do-camera-look-at ( CAMERA -- )
+
+ [let | EYE [ CAMERA pos>> ]
+ FOCUS [ CAMERA clone 1 step-turtle pos>> ]
+ UP [ CAMERA clone 90 pitch-up 1 step-turtle pos>> CAMERA pos>> v- ]
+ |
+
+ EYE FOCUS UP gl-look-at ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: generate-display-list ( L-SYSTEM -- )
+
+ L-SYSTEM find-gl-context
+
+ L-SYSTEM display-list>> GL_COMPILE glNewList
+
+ turtle
+ L-SYSTEM turtle-values>> [ ] or call
+ L-SYSTEM string>> L-SYSTEM axiom>> or
+ L-SYSTEM commands>>
+ interpret-string
+ drop
+
+ glEndList ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <L-system> draw-gadget* ( L-SYSTEM -- )
+
+ black gl-clear
+
+ GL_FLAT glShadeModel
+
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ -1 1 -1 1 1.5 200 glFrustum
+
+ GL_MODELVIEW glMatrixMode
+
+ glLoadIdentity
+
+ L-SYSTEM camera>> do-camera-look-at
+
+ GL_FRONT_AND_BACK GL_LINE glPolygonMode
+
+ ! draw axis
+ white gl-color GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
+
+ ! rotate pedestal
+
+ L-SYSTEM pedestal>> 0 0 1 glRotated
+
+ L-SYSTEM display-list>> glCallList ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <L-system> graft* ( L-SYSTEM -- )
+
+ L-SYSTEM find-gl-context
+
+ 1 glGenLists L-SYSTEM (>>display-list) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <L-system> pref-dim* ( L-SYSTEM -- dim ) { 400 400 } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: with-camera ( L-SYSTEM QUOT -- )
+ L-SYSTEM camera>> QUOT call drop
+ L-SYSTEM relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<L-system>
+H{
+ { T{ key-down f f "LEFT" } [ [ 5 turn-left ] with-camera ] }
+ { T{ key-down f f "RIGHT" } [ [ 5 turn-right ] with-camera ] }
+ { T{ key-down f f "UP" } [ [ 5 pitch-down ] with-camera ] }
+ { T{ key-down f f "DOWN" } [ [ 5 pitch-up ] with-camera ] }
+
+ { T{ key-down f f "a" } [ [ 1 step-turtle ] with-camera ] }
+ { T{ key-down f f "z" } [ [ -1 step-turtle ] with-camera ] }
+
+ { T{ key-down f f "q" } [ [ 5 roll-left ] with-camera ] }
+ { T{ key-down f f "w" } [ [ 5 roll-right ] with-camera ] }
+
+ { T{ key-down f { A+ } "LEFT" } [ [ 1 strafe-left ] with-camera ] }
+ { T{ key-down f { A+ } "RIGHT" } [ [ 1 strafe-right ] with-camera ] }
+ { T{ key-down f { A+ } "UP" } [ [ 1 strafe-up ] with-camera ] }
+ { T{ key-down f { A+ } "DOWN" } [ [ 1 strafe-down ] with-camera ] }
+
+ { T{ key-down f f "r" } [ start-rotation-thread ] }
+
+ {
+ T{ key-down f f "x" }
+ [
+ dup iterate-L-system-string
+ dup generate-display-list
+ dup relayout-1
+ drop
+ ]
+ }
+
+ { T{ key-down f f "F1" } [ drop "L-system" help-window ] }
+
+}
+set-gestures
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: L-system ( -- L-system )
+
+ <L-system> new-gadget
+
+ 0 >>pedestal
+
+ ! turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ;
+
+ turtle 90 pitch-down -5 step-turtle 2 strafe-up >>camera
+
+ dup start-rotation-thread
+
+ ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "L-system" "L-system"
+
+"Press 'x' to iterate the L-system." $nl
+
+"Camera control:"
+
+{ $table
+
+ { "a" "Forward" }
+ { "z" "Backward" }
+
+ { "LEFT" "Turn left" }
+ { "RIGHT" "Turn right" }
+ { "UP" "Pitch down" }
+ { "DOWN" "Pitch up" }
+
+ { "q" "Roll left" }
+ { "w" "Roll right" } } ;
+
+ABOUT: "L-system"
\ No newline at end of file
--- /dev/null
+
+USING: accessors ui L-system ;
+
+IN: L-system.models.abop-1
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: abop-1 ( <L-system> -- <L-system> )
+
+ L-parser-dialect >>commands
+
+ "c(12)FFAL" >>axiom
+
+ {
+ { "A" "F [ & '(.8) ! B L ] >(137) ' !(.9) A" }
+ { "B" "F [ - '(.8) !(.9) $ C L ] ' !(.9) C" }
+ { "C" "F [ + '(.8) !(.9) $ B L ] ' !(.9) B" }
+
+ { "L" " ~ c(8) { +(30) f -(120) f -(120) f }" }
+ }
+ >>rules ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system abop-1 "L-system" open-window ] with-ui ;
+
+MAIN: main
--- /dev/null
+
+USING: accessors ui L-system ;
+
+IN: L-system.models.abop-2
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: abop-2 ( <L-system> -- <L-system> )
+
+ L-parser-dialect >>commands
+
+ [ 30 >>angle ] >>turtle-values
+
+ "c(12)FAL" >>axiom
+
+ {
+ { "A" "F [&'(.7)!BL] >(137) [&'(.6)!BL] >(137) '(.9) !(.9) A" }
+
+ { "B" "F [- '(.7) !(.9) $ C L] '(.9) !(.9) C" }
+ { "C" "F [+ '(.7) !(.9) $ B L] '(.9) !(.9) B" }
+
+ { "L" "~c(8){+f(.1)-f(.1)-f(.1)+|+f(.1)-f(.1)-f(.1)}" }
+
+ } >>rules ;
+
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system abop-2 "L-system" open-window ] with-ui ;
+
+MAIN: main
--- /dev/null
+
+USING: accessors ui L-system ;
+
+IN: L-system.models.abop-3
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: abop-3 ( <L-system> -- <L-system> )
+
+ L-parser-dialect >>commands
+
+ [ 30 >>angle ] >>turtle-values
+
+ "c(12)FA" >>axiom
+
+ {
+ { "A" "!(.9)t(.4)FB>(94)B>(132)B" }
+ { "B" "[&t(.4)F$A]" }
+ { "F" "'(1.25)F'(.8)" }
+ }
+ >>rules ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system abop-3 "L-system" open-window ] with-ui ;
+
+MAIN: main
--- /dev/null
+
+USING: accessors ui L-system ;
+
+IN: L-system.models.abop-4
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: abop-4 ( <L-system> -- <L-system> )
+
+ L-parser-dialect >>commands
+
+ [ 18 >>angle ] >>turtle-values
+
+ "c(12)&(20)N" >>axiom
+
+ {
+ {
+ "N"
+ "FII[&(60)rY]>(90)[&(45)'(0.8)rA]>(90)[&(60)rY]>(90)[&(45)'(0.8)rD]!FIK"
+ }
+ { "Y" "[c(4){++l.--l.--l.++|++l.--l.--l.}]" }
+ { "l" "g(.2)l" }
+ { "K" "[!c(2)FF>w>(72)w>(72)w>(72)w>(72)w]" }
+ { "w" "[c(2)^!F][c(5)&(72){-(54)f(3)+(54)f(3)|-(54)f(3)+(54)f(3)}]" }
+ { "f" "_" }
+
+ { "A" "B" }
+ { "B" "C" }
+ { "C" "D" }
+ { "D" "E" }
+ { "E" "G" }
+ { "G" "H" }
+ { "H" "N" }
+
+ { "I" "FoO" }
+ { "O" "FoP" }
+ { "P" "FoQ" }
+ { "Q" "FoR" }
+ { "R" "FoS" }
+ { "S" "FoT" }
+ { "T" "FoU" }
+ { "U" "FoV" }
+ { "V" "FoW" }
+ { "W" "FoX" }
+ { "X" "_" }
+
+ { "o" "$t(-0.03)" }
+ { "r" "~(30)" }
+ }
+ >>rules ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system abop-4 "L-system" open-window ] with-ui ;
+
+MAIN: main
--- /dev/null
+
+USING: accessors ui L-system ;
+
+IN: L-system.models.abop-5-angular
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: abop-5-angular ( <L-system> -- <L-system> )
+
+ L-parser-dialect >>commands
+
+ "&(90)+(90)a" >>axiom
+
+ {
+ { "a" "F[+(45)l][-(45)l]^;ca" }
+
+ { "l" "j" }
+ { "j" "h" }
+ { "h" "s" }
+ { "s" "d" }
+ { "d" "x" }
+ { "x" "a" }
+
+ { "F" "'(1.17)F'(.855)" }
+ }
+ >>rules ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system abop-5-angular "L-system" open-window ] with-ui ;
+
+MAIN: main
+
\ No newline at end of file
--- /dev/null
+
+USING: accessors ui L-system ;
+
+IN: L-system.models.abop-5
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: abop-5 ( <L-system> -- <L-system> )
+
+ L-parser-dialect >>commands
+
+ [ 5 >>angle ] >>turtle-values
+
+ "a" >>axiom
+
+ {
+ { "a" "F[+(45)l][-(45)l]^;ca" }
+
+ { "l" "j" }
+ { "j" "h" }
+ { "h" "s" }
+ { "s" "d" }
+ { "d" "x" }
+ { "x" "a" }
+
+ { "F" "'(1.17)F'(.855)" }
+ }
+ >>rules ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system abop-5 "L-system" open-window ] with-ui ;
+
+MAIN: main
+
\ No newline at end of file
--- /dev/null
+
+USING: accessors ui L-system ;
+
+IN: L-system.models.abop-6
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: abop-6 ( <L-system> -- <L-system> )
+
+ L-parser-dialect >>commands
+
+ [ 5 >>angle ] >>turtle-values
+
+ ! "&(90)+(90)FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x"
+ "FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x"
+ >>axiom
+
+ {
+ { "a" "F[cdx][cex]F!(.9)a" }
+ { "x" "a" }
+
+ { "d" "+d" }
+ { "e" "-e" }
+
+ { "F" "'(1.25)F'(.8)" }
+ }
+ >>rules ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system abop-6 "L-system" open-window ] with-ui ;
+
+MAIN: main
+
\ No newline at end of file
--- /dev/null
+
+USING: accessors ui L-system ;
+
+IN: L-system.models.airhorse
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: airhorse ( <L-system> -- <L-system> )
+
+ L-parser-dialect >>commands
+
+ [ 10 >>angle ] >>turtle-values
+
+ "C" >>axiom
+
+ {
+ { "C" "LBW" }
+
+ { "B" "[[''aH]|[g]]" }
+ { "a" "Fs+;'a" }
+ { "g" "Ft+;'g" }
+ { "s" "[::cc!!!!&&[FFcccZ]^^^^FFcccZ]" }
+ { "t" "[c!!!!&[FF]^^FF]" }
+
+ { "L" "O" }
+ { "O" "P" }
+ { "P" "Q" }
+ { "Q" "R" }
+ { "R" "U" }
+ { "U" "X" }
+ { "X" "Y" }
+ { "Y" "V" }
+ { "V" "[cc!!!&(90)[Zp]|[Zp]]" }
+ { "p" "h>(120)h>(120)h" }
+ { "h" "[+(40)!F'''p]" }
+
+ { "H" "[cccci[>(50)dcFFF][<(50)ecFFF]]" }
+ { "d" "Z!&Z!&:'d" }
+ { "e" "Z!^Z!^:'e" }
+ { "i" "-:/i" }
+
+ { "W" "[%[!!cb][<<<!!cb][>>>!!cb]]" }
+ { "b" "Fl!+Fl+;'b" }
+ { "l" "[-cc{--z++z++z--|--z++z++z}]" }
+ }
+ >>rules ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system airhorse "L-system" open-window ] with-ui ;
+
+MAIN: main
+
\ No newline at end of file
--- /dev/null
+
+USING: accessors ui L-system ;
+
+IN: L-system.models.tree-5
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: tree-5 ( <L-system> -- <L-system> )
+
+ L-parser-dialect >>commands
+
+ [ 5 >>angle ] >>turtle-values
+
+ "c(4)FFS" >>axiom
+
+ {
+ { "S" "FFR>(60)R>(60)R>(60)R>(60)R>(60)R>(30)S" }
+ { "R" "[Ba]" }
+ { "a" "$tF[Cx]Fb" }
+ { "b" "$tF[Dy]Fa" }
+ { "B" "&B" }
+ { "C" "+C" }
+ { "D" "-D" }
+
+ { "x" "a" }
+ { "y" "b" }
+
+ { "F" "'(1.25)F'(.8)" }
+ }
+ >>rules ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: main ( -- ) [ L-system tree-5 "L-system" open-window ] with-ui ;
+
+MAIN: main
+
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel
+ namespaces
+ arrays
+ accessors
+ strings
+ sequences
+ locals
+ threads
+ math
+ math.functions
+ math.trig
+ math.order
+ math.ranges
+ math.vectors
+ random
+ calendar
+ opengl.gl
+ opengl
+ ui
+ ui.gadgets
+ ui.gadgets.tracks
+ ui.gadgets.frames
+ ui.gadgets.grids
+ ui.render
+ multi-methods
+ multi-method-syntax
+ combinators.short-circuit
+ processing.shapes
+ flatland ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IN: boids
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: constrain ( n a b -- n ) rot min max ;
+
+: angle-between ( vec vec -- angle )
+ [ v. ] [ [ norm ] bi@ * ] 2bi / -1 1 constrain acos rad>deg ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ;
+
+: relative-angle ( self other -- angle )
+ over vel>> -rot relative-position angle-between ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: in-radius? ( self other radius -- ? ) [ distance ] dip <= ;
+: in-view? ( self other angle -- ? ) [ relative-angle ] dip 2 / <= ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: vsum ( vector-of-vectors -- vec ) { 0 0 } [ v+ ] reduce ;
+
+: vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ;
+
+: average-position ( boids -- pos ) [ pos>> ] map vaverage ;
+: average-velocity ( boids -- vel ) [ vel>> ] map vaverage ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <boid> < <vel> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <behaviour>
+ { weight initial: 1.0 }
+ { view-angle initial: 180 }
+ { radius } ;
+
+TUPLE: <cohesion> < <behaviour> { radius initial: 75 } ;
+TUPLE: <alignment> < <behaviour> { radius initial: 50 } ;
+TUPLE: <separation> < <behaviour> { radius initial: 25 } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: within-neighborhood? ( SELF OTHER BEHAVIOUR -- ? )
+
+ SELF OTHER
+ {
+ [ BEHAVIOUR radius>> in-radius? ]
+ [ BEHAVIOUR view-angle>> in-view? ]
+ [ eq? not ]
+ }
+ 2&& ;
+
+:: neighborhood ( SELF OTHERS BEHAVIOUR -- boids )
+ OTHERS [| OTHER | SELF OTHER BEHAVIOUR within-neighborhood? ] filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: normalize* ( u -- v ) { 0.001 0.001 } v+ normalize ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: force* ( sequence <boid> <behaviour> -- force )
+
+:: cohesion-force ( OTHERS SELF BEHAVIOUR -- force )
+ OTHERS average-position SELF pos>> v- normalize* BEHAVIOUR weight>> v*n ;
+
+:: alignment-force ( OTHERS SELF BEHAVIOUR -- force )
+ OTHERS average-velocity normalize* BEHAVIOUR weight>> v*n ;
+
+:: separation-force ( OTHERS SELF BEHAVIOUR -- force )
+ SELF pos>> OTHERS average-position v- normalize* BEHAVIOUR weight>> v*n ;
+
+METHOD: force* ( sequence <boid> <cohesion> -- force ) cohesion-force ;
+METHOD: force* ( sequence <boid> <alignment> -- force ) alignment-force ;
+METHOD: force* ( sequence <boid> <separation> -- force ) separation-force ;
+
+:: force ( OTHERS SELF BEHAVIOUR -- force )
+ SELF OTHERS BEHAVIOUR neighborhood
+ [ { 0 0 } ]
+ [ SELF BEHAVIOUR force* ]
+ if-empty ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: random-boids ( count -- boids )
+ [
+ drop
+ <boid> new
+ 2 [ drop 1000 random ] map >>pos
+ 2 [ drop -10 10 [a,b] random ] map >>vel
+ ]
+ map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: draw-boid ( boid -- )
+ glPushMatrix
+ dup pos>> gl-translate-2d
+ vel>> first2 rect> arg rad>deg 0 0 1 glRotated
+ { { 0 5 } { 0 -5 } { 20 0 } } triangle
+ fill-mode
+ glPopMatrix ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gadget->sky ( gadget -- sky ) { 0 0 } swap dim>> <rectangle> boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: syntax ! Switch back to non-multi-method 'TUPLE:' syntax
+
+TUPLE: <boids-gadget> < gadget paused boids behaviours time-slice ;
+
+M: <boids-gadget> pref-dim* ( <boids-gadget> -- dim ) drop { 600 400 } ;
+M: <boids-gadget> ungraft* ( <boids-gadget> -- ) t >>paused drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-system ( BOIDS-GADGET -- )
+
+ [let | SKY [ BOIDS-GADGET gadget->sky ]
+ BOIDS [ BOIDS-GADGET boids>> ]
+ TIME-SLICE [ BOIDS-GADGET time-slice>> ]
+ BEHAVIOURS [ BOIDS-GADGET behaviours>> ] |
+
+ BOIDS
+
+ [| SELF |
+
+ [wlet | force-due-to [| BEHAVIOUR | BOIDS SELF BEHAVIOUR force ] |
+
+ ! F = m a. M is 1. So F = a.
+
+ [let | ACCEL [ BEHAVIOURS [ force-due-to ] map vsum ] |
+
+ [let | POS [ SELF pos>> SELF vel>> TIME-SLICE v*n v+ ]
+ VEL [ SELF vel>> ACCEL TIME-SLICE v*n v+ ] |
+
+ [let | POS [ POS SKY wrap ]
+ VEL [ VEL normalize* ] |
+
+ T{ <boid> f POS VEL } ] ] ] ]
+
+ ]
+
+ map
+
+ BOIDS-GADGET (>>boids) ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <boids-gadget> draw-gadget* ( BOIDS-GADGET -- )
+ origin get
+ [ BOIDS-GADGET boids>> [ draw-boid ] each ]
+ with-translation ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-boids-thread ( GADGET -- )
+ GADGET f >>paused drop
+ [
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
+ if
+ ]
+ loop
+ ]
+ in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: default-behaviours ( -- seq )
+ { <cohesion> <alignment> <separation> } [ new ] map ;
+
+: boids-gadget ( -- gadget )
+ <boids-gadget> new-gadget
+ 100 random-boids >>boids
+ default-behaviours >>behaviours
+ 10 >>time-slice
+ t >>clipped? ;
+
+: run-boids ( -- ) boids-gadget dup "Boids" open-window start-boids-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: math.parser
+ ui.gadgets.labels
+ ui.gadgets.buttons
+ ui.gadgets.packs ;
+
+: truncate-number ( n -- n ) 10 * round 10 / ;
+
+:: make-behaviour-control ( NAME BEHAVIOUR -- gadget )
+ [let | NAME-LABEL [ NAME <label> reverse-video-theme ]
+ VALUE-LABEL [ 20 32 <string> <label> reverse-video-theme ] |
+
+ [wlet | update-value-label [ ! ( -- )
+ BEHAVIOUR weight>> truncate-number number>string
+ VALUE-LABEL
+ (>>string) ] |
+
+ update-value-label
+
+ <pile> 1 >>fill
+ { 1 0 } <track>
+ NAME-LABEL 0.5 track-add
+ VALUE-LABEL 0.5 track-add
+ add-gadget
+
+ "+0.1"
+ [
+ drop
+ BEHAVIOUR [ 0.1 + ] change-weight drop
+ update-value-label
+ ]
+ <bevel-button> add-gadget
+
+ "-0.1"
+ [
+ drop
+ BEHAVIOUR weight>> 0.1 >
+ [
+ BEHAVIOUR [ 0.1 - ] change-weight drop
+ update-value-label
+ ]
+ when
+ ]
+ <bevel-button> add-gadget ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: make-population-control ( BOIDS-GADGET -- gadget )
+ [let | VALUE-LABEL [ 20 32 <string> <label> reverse-video-theme ] |
+
+ [wlet | update-value-label [ ( -- )
+ BOIDS-GADGET boids>> length number>string
+ VALUE-LABEL
+ (>>string) ] |
+
+ update-value-label
+
+ <pile> 1 >>fill
+
+ { 1 0 } <track>
+ "Population: " <label> reverse-video-theme 0.5 track-add
+ VALUE-LABEL 0.5 track-add
+ add-gadget
+
+ "Add 10"
+ [
+ drop
+ BOIDS-GADGET
+ BOIDS-GADGET boids>> 10 random-boids append
+ >>boids
+ drop
+ update-value-label
+ ]
+ <bevel-button>
+ add-gadget
+
+ "Sub 10"
+ [
+ drop
+ BOIDS-GADGET boids>> length 10 >
+ [
+ BOIDS-GADGET
+ BOIDS-GADGET boids>> 10 tail
+ >>boids
+ drop
+ update-value-label
+ ]
+ when
+ ]
+ <bevel-button>
+ add-gadget ] ] ( gadget -- gadget ) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: pause-toggle ( BOIDS-GADGET -- )
+ BOIDS-GADGET paused>>
+ [ BOIDS-GADGET start-boids-thread ]
+ [ BOIDS-GADGET t >>paused drop ]
+ if ;
+
+:: randomize-boids ( BOIDS-GADGET -- )
+ BOIDS-GADGET BOIDS-GADGET boids>> length random-boids >>boids drop ;
+
+: boids-app ( -- )
+
+ [let | BOIDS-GADGET [ boids-gadget ] |
+
+ <frame>
+
+ <shelf>
+
+ 1 >>fill
+
+ "Pause" [ drop BOIDS-GADGET pause-toggle ] <bevel-button> add-gadget
+
+ "Randomize"
+ [ drop BOIDS-GADGET randomize-boids ] <bevel-button> add-gadget
+
+ BOIDS-GADGET make-population-control add-gadget
+
+ "Cohesion: " BOIDS-GADGET behaviours>> first make-behaviour-control
+ "Alignment: " BOIDS-GADGET behaviours>> second make-behaviour-control
+ "Separation: " BOIDS-GADGET behaviours>> third make-behaviour-control
+
+ [ add-gadget ] tri@
+
+ @top grid-add
+
+ BOIDS-GADGET @center grid-add
+
+ "Boids" open-window
+
+ BOIDS-GADGET start-boids-thread ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: boids-main ( -- ) [ boids-app ] with-ui ;
+
+MAIN: boids-main
\ No newline at end of file
--- /dev/null
+Artificial life program simulating simulating the flocking behaviour of birds
--- /dev/null
+
+USING: kernel syntax accessors sequences
+ arrays calendar
+ combinators.cleave combinators.short-circuit
+ locals math math.constants math.functions math.libm
+ math.order math.points math.vectors
+ namespaces random sequences threads ui ui.gadgets ui.gestures
+ math.ranges
+ colors
+ colors.gray
+ vars
+ multi-methods
+ multi-method-syntax
+ processing.shapes
+ frame-buffer ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IN: bubble-chamber
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! This is a Factor implementation of an art piece by Jared Tarbell:
+!
+! http://complexification.net/gallery/machines/bubblechamber/
+!
+! Jared's version is written in Processing (Java)
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! processing
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
+
+: 1random ( b -- num ) 0 swap 2random ;
+
+: at-fraction ( seq fraction -- val ) over length 1- * swap nth ;
+
+: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
+
+: mouse ( -- point ) hand-loc get ;
+
+: mouse-x ( -- x ) mouse first ;
+: mouse-y ( -- y ) mouse second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: collide ( particle -- )
+GENERIC: move ( particle -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: particle
+ bubble-chamber pos vel speed speed-d theta theta-d theta-dd myc mya ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: initialize-particle ( particle -- particle )
+
+ 0 0 {2} >>pos
+ 0 0 {2} >>vel
+
+ 0 >>speed
+ 0 >>speed-d
+ 0 >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ 0 0 0 1 rgba boa >>myc
+ 0 0 0 1 rgba boa >>mya ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: center ( particle -- point ) bubble-chamber>> size>> 2 v/n ;
+
+DEFER: collision-theta
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: theta-dd-small? ( par limit -- par ? ) [ dup theta-dd>> abs ] dip < ;
+
+: random-theta-dd ( par a b -- par ) 2random >>theta-dd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: turn ( particle -- particle )
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ >>vel ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ;
+: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
+: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ;
+: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: out-of-bounds? ( PARTICLE -- ? )
+ [let | X [ PARTICLE pos>> first ]
+ Y [ PARTICLE pos>> second ]
+ WIDTH [ PARTICLE bubble-chamber>> size>> first ]
+ HEIGHT [ PARTICLE bubble-chamber>> size>> second ] |
+
+ [let | LEFT [ WIDTH neg ]
+ RIGHT [ WIDTH 2 * ]
+ BOTTOM [ HEIGHT neg ]
+ TOP [ HEIGHT 2 * ] |
+
+ { [ X LEFT < ] [ X RIGHT > ] [ Y BOTTOM < ] [ Y TOP > ] } 0|| ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.axion
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <axion> < particle ;
+
+: axion ( -- <axion> ) <axion> new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide ( <axion> -- )
+
+ dup center >>pos
+ 2 pi * 1random >>theta
+ 1.0 6.0 2random >>speed
+ 0.998 1.000 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
+
+! : axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} \ stroke-color set ;
+! : axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} \ stroke-color set ;
+
+: axion-white ( dy -- dy ) dup 1 swap dy>alpha gray boa \ stroke-color set ;
+: axion-black ( dy -- dy ) dup 0 swap dy>alpha gray boa \ stroke-color set ;
+
+: axion-point- ( particle dy -- particle ) [ dup pos>> ] dip v-y point ;
+: axion-point+ ( particle dy -- particle ) [ dup pos>> ] dip v+y point ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move ( <axion> -- )
+
+ T{ gray f 0.06 0.59 } \ stroke-color set
+ dup pos>> point
+
+ 1 4 [a,b] [ axion-white axion-point- ] each
+ 1 4 [a,b] [ axion-black axion-point+ ] each
+
+ dup vel>> move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ [ ] [ speed-d>> 0.9999 * ] bi >>speed-d
+
+ 1000 random 996 >
+ [
+ dup speed>> neg >>speed
+ dup speed-d>> neg 2 + >>speed-d
+
+ 100 random 30 > [ collide ] [ drop ] if
+ ]
+ [ drop ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.hadron
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <hadron> < particle ;
+
+: hadron ( -- <hadron> ) <hadron> new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide ( <hadron> -- )
+
+ dup center >>pos
+ 2 pi * 1random >>theta
+ 0.5 3.5 2random >>speed
+ 0.996 1.001 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
+
+ 0 1 0 1 rgba boa >>myc
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move ( <hadron> -- )
+
+ T{ gray f 1 0.11 } \ stroke-color set dup pos>> 1 v-y point
+ T{ gray f 0 0.11 } \ stroke-color set dup pos>> 1 v+y point
+
+ dup vel>> move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ 1000 random 997 >
+ [
+ 1.0 >>speed-d
+ 0.00001 >>theta-dd
+
+ 100 random 70 > [ dup collide ] when
+ ]
+ when
+
+ dup out-of-bounds? [ collide ] [ drop ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.muon.colors
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: good-colors ( -- seq )
+ {
+ T{ rgba f 0.23 0.14 0.17 1 }
+ T{ rgba f 0.23 0.14 0.15 1 }
+ T{ rgba f 0.21 0.14 0.15 1 }
+ T{ rgba f 0.51 0.39 0.33 1 }
+ T{ rgba f 0.49 0.33 0.20 1 }
+ T{ rgba f 0.55 0.45 0.32 1 }
+ T{ rgba f 0.69 0.63 0.51 1 }
+ T{ rgba f 0.64 0.39 0.18 1 }
+ T{ rgba f 0.73 0.42 0.20 1 }
+ T{ rgba f 0.71 0.45 0.29 1 }
+ T{ rgba f 0.79 0.45 0.22 1 }
+ T{ rgba f 0.82 0.56 0.34 1 }
+ T{ rgba f 0.88 0.72 0.49 1 }
+ T{ rgba f 0.85 0.69 0.40 1 }
+ T{ rgba f 0.96 0.92 0.75 1 }
+ T{ rgba f 0.99 0.98 0.87 1 }
+ T{ rgba f 0.85 0.82 0.69 1 }
+ T{ rgba f 0.99 0.98 0.87 1 }
+ T{ rgba f 0.82 0.82 0.79 1 }
+ T{ rgba f 0.65 0.69 0.67 1 }
+ T{ rgba f 0.53 0.60 0.55 1 }
+ T{ rgba f 0.57 0.53 0.68 1 }
+ T{ rgba f 0.47 0.42 0.56 1 }
+ } ;
+
+: anti-colors ( -- seq ) good-colors <reversed> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
+
+: set-good-color ( particle -- particle )
+ color-fraction dup 0 1 between?
+ [ good-colors at-fraction-of >>myc ]
+ [ drop ]
+ if ;
+
+: set-anti-color ( particle -- particle )
+ color-fraction dup 0 1 between?
+ [ anti-colors at-fraction-of >>mya ]
+ [ drop ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.muon
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <muon> < particle ;
+
+: muon ( -- <muon> ) <muon> new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide ( <muon> -- )
+
+ dup center >>pos
+ 2 32 [a,b] random >>speed
+ 0.0001 0.001 2random >>speed-d
+
+ dup collision-theta -0.1 0.1 2random + >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] while
+
+ set-good-color
+ set-anti-color
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move ( <muon> -- )
+
+ [let | MUON [ ] |
+
+ [let | WIDTH [ MUON bubble-chamber>> size>> first ] |
+
+ MUON
+
+ dup myc>> 0.16 >>alpha \ stroke-color set
+ dup pos>> point
+
+ dup mya>> 0.16 >>alpha \ stroke-color set
+ dup pos>> first2 [ WIDTH swap - ] dip 2array point
+
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ move-by
+
+ step-theta
+ step-theta-d
+ step-speed-sub
+
+ dup out-of-bounds? [ collide ] [ drop ] if ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.quark
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <quark> < particle ;
+
+: quark ( -- <quark> ) <quark> new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide ( <quark> -- )
+
+ dup center >>pos
+ dup collision-theta -0.11 0.11 2random + >>theta
+ 0.5 3.0 2random >>speed
+
+ 0.996 1.001 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move ( <quark> -- )
+
+ [let | QUARK [ ] |
+
+ [let | WIDTH [ QUARK bubble-chamber>> size>> first ] |
+
+ QUARK
+
+ dup myc>> 0.13 >>alpha \ stroke-color set
+ dup pos>> point
+
+ dup pos>> first2 [ WIDTH swap - ] dip 2array point
+
+ [ ] [ vel>> ] bi move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ 1000 random 997 >
+ [
+ dup speed>> neg >>speed
+ 2 over speed-d>> - >>speed-d
+ ]
+ when
+
+ dup out-of-bounds? [ collide ] [ drop ] if ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: syntax ! Switch back to non-multi-method 'TUPLE:' syntax
+
+TUPLE: <bubble-chamber> < <frame-buffer>
+ paused particles collision-theta size ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : randomize-collision-theta ( bubble-chamber -- bubble-chamber )
+! 0 2 pi * 0.001 <range> random >>collision-theta ;
+
+: randomize-collision-theta ( bubble-chamber -- bubble-chamber )
+ pi neg pi 0.001 <range> random >>collision-theta ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collision-theta ( particle -- theta ) bubble-chamber>> collision-theta>> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: <bubble-chamber> pref-dim* ( gadget -- dim ) size>> ;
+
+M: <bubble-chamber> ungraft* ( <bubble-chamber> -- ) t >>paused drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: iterate-particle ( particle -- ) move ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <bubble-chamber> update-frame-buffer ( BUBBLE-CHAMBER -- )
+
+ BUBBLE-CHAMBER particles>> [ iterate-particle ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: iterate-system ( <bubble-chamber> -- ) drop ;
+
+:: start-bubble-chamber-thread ( GADGET -- )
+ GADGET f >>paused drop
+ [
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
+ if
+ ]
+ loop
+ ]
+ in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bubble-chamber ( -- <bubble-chamber> )
+ <bubble-chamber> new-gadget
+ { 1000 1000 } >>size
+ randomize-collision-theta ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bubble-chamber-window ( -- <bubble-chamber> )
+ bubble-chamber
+ dup start-bubble-chamber-thread
+ dup "Bubble Chamber" open-window ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: add-particle ( BUBBLE-CHAMBER PARTICLE -- bubble-chamber )
+
+ PARTICLE BUBBLE-CHAMBER >>bubble-chamber drop
+
+ BUBBLE-CHAMBER BUBBLE-CHAMBER particles>> PARTICLE suffix >>particles ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: mouse->collision-theta ( BUBBLE-CHAMBER -- BUBBLE-CHAMBER )
+ mouse
+ BUBBLE-CHAMBER size>> 2 v/n
+ v-
+ first2
+ fatan2
+ BUBBLE-CHAMBER (>>collision-theta)
+ BUBBLE-CHAMBER ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: mouse-pressed ( BUBBLE-CHAMBER -- )
+
+ BUBBLE-CHAMBER mouse->collision-theta drop
+
+ 11
+ [
+ BUBBLE-CHAMBER particles>> [ <hadron>? ] filter random [ collide ] when*
+ BUBBLE-CHAMBER particles>> [ <quark>? ] filter random [ collide ] when*
+ BUBBLE-CHAMBER particles>> [ <muon>? ] filter random [ collide ] when*
+ ]
+ times ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<bubble-chamber> H{ { T{ button-down } [ mouse-pressed ] } } set-gestures
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collide-random-particle ( bubble-chamber -- bubble-chamber )
+ dup particles>> random collide ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: big-bang ( bubble-chamber -- bubble-chamber )
+ dup particles>> [ collide ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collide-one-of-each ( bubble-chamber -- bubble-chamber )
+ dup
+ particles>>
+ [ [ <muon>? ] filter random collide ]
+ [ [ <quark>? ] filter random collide ]
+ [ [ <hadron>? ] filter random collide ]
+ tri ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Some initial configurations
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ten-hadrons ( -- )
+ bubble-chamber-window
+ 10 [ drop hadron add-particle ] each
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: original ( -- )
+
+ bubble-chamber-window
+
+ 1789 [ muon add-particle ] times
+ 1300 [ quark add-particle ] times
+ 1000 [ hadron add-particle ] times
+ 111 [ axion add-particle ] times
+
+ particles>>
+ [ [ <muon>? ] filter random collide ]
+ [ [ <quark>? ] filter random collide ]
+ [ [ <hadron>? ] filter random collide ]
+ tri ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: hadron-chamber ( -- )
+ bubble-chamber-window
+ 1000 [ hadron add-particle ] times
+ big-bang
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: quark-chamber ( -- )
+ bubble-chamber-window
+ 100 [ quark add-particle ] times
+ big-bang
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: small ( -- )
+ <bubble-chamber> new-gadget
+ { 200 200 } >>size
+ randomize-collision-theta
+ dup start-bubble-chamber-thread
+ dup "Bubble Chamber" open-window
+
+ 42 [ muon add-particle ] times
+ 30 [ quark add-particle ] times
+ 21 [ hadron add-particle ] times
+ 7 [ axion add-particle ] times
+
+ collide-one-of-each
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: medium ( -- )
+ <bubble-chamber> new-gadget
+ { 400 400 } >>size
+ randomize-collision-theta
+ dup start-bubble-chamber-thread
+ dup "Bubble Chamber" open-window
+
+ 100 [ muon add-particle ] times
+ 81 [ quark add-particle ] times
+ 60 [ hadron add-particle ] times
+ 9 [ axion add-particle ] times
+
+ collide-one-of-each
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: large ( -- )
+ <bubble-chamber> new-gadget
+ { 600 600 } >>size
+ randomize-collision-theta
+ dup start-bubble-chamber-thread
+ dup "Bubble Chamber" open-window
+
+ 550 [ muon add-particle ] times
+ 339 [ quark add-particle ] times
+ 100 [ hadron add-particle ] times
+ 11 [ axion add-particle ] times
+
+ collide-one-of-each
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Experimental
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: muon-chamber ( -- )
+ bubble-chamber-window
+ 1000 [ muon add-particle ] times
+ dup particles>> [ collide randomize-collision-theta ] each
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: original-big-bang ( -- )
+ bubble-chamber
+ { 1000 1000 } >>size
+ dup start-bubble-chamber-thread
+ dup "Bubble Chamber" open-window
+
+ 1789 [ muon add-particle ] times
+ 1300 [ quark add-particle ] times
+ 1000 [ hadron add-particle ] times
+ 111 [ axion add-particle ] times
+
+ big-bang
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: original-big-bang-variant ( -- )
+ bubble-chamber-window
+ 1789 [ muon add-particle ] times
+ 1300 [ quark add-particle ] times
+ 1000 [ hadron add-particle ] times
+ 111 [ axion add-particle ] times
+ dup particles>> [ collide randomize-collision-theta ] each
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.hadron-chamber
+
+: main ( -- ) [ hadron-chamber ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.large
+
+: main ( -- ) [ large ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.medium
+
+: main ( -- ) [ medium ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.original
+
+: main ( -- ) [ original ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.quark-chamber
+
+: main ( -- ) [ quark-chamber ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.small
+
+: main ( -- ) [ small ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.ten-hadrons
+
+: main ( -- ) [ ten-hadrons ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+Sampo Vuori
--- /dev/null
+! Cairo "Hello World" demo
+! Copyright (c) 2007 Sampo Vuori
+! License: http://factorcode.org/license.txt
+!
+! This example is an adaptation of the following cairo sample code:
+! http://cairographics.org/samples/text/
+
+
+USING: cairo.ffi math math.constants byte-arrays kernel ui
+ui.render combinators ui.gadgets opengl.gl accessors
+namespaces opengl ;
+
+IN: cairo-demo
+
+: make-image-array ( -- array )
+ 384 256 4 * * <byte-array> ;
+
+: convert-array-to-surface ( array -- cairo_surface_t )
+ CAIRO_FORMAT_ARGB32 384 256 over 4 *
+ cairo_image_surface_create_for_data ;
+
+TUPLE: cairo-demo-gadget < gadget image-array cairo-t ;
+
+M: cairo-demo-gadget draw-gadget* ( gadget -- )
+ origin get [
+ 0 0 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ [ 384 256 GL_RGBA GL_UNSIGNED_BYTE ] dip
+ image-array>> glDrawPixels
+ ] with-translation ;
+
+: create-surface ( gadget -- cairo_surface_t )
+ make-image-array [ swap (>>image-array) ] keep
+ convert-array-to-surface ;
+
+: init-cairo ( gadget -- cairo_t )
+ create-surface cairo_create ;
+
+M: cairo-demo-gadget pref-dim* drop { 384 256 } ;
+
+ERROR: no-cairo-t ;
+
+<PRIVATE
+
+: draw-hello-world ( gadget -- )
+ cairo-t>> [ no-cairo-t ] unless*
+ {
+ [
+ "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
+ cairo_select_font_face
+ ]
+ [ 90.0 cairo_set_font_size ]
+ [ 10.0 135.0 cairo_move_to ]
+ [ "Hello" cairo_show_text ]
+ [ 70.0 165.0 cairo_move_to ]
+ [ "World" cairo_text_path ]
+ [ 0.5 0.5 1 cairo_set_source_rgb ]
+ [ cairo_fill_preserve ]
+ [ 0 0 0 cairo_set_source_rgb ]
+ [ 2.56 cairo_set_line_width ]
+ [ cairo_stroke ]
+ [ 1 0.2 0.2 0.6 cairo_set_source_rgba ]
+ [ 10.0 135.0 5.12 0 pi 2 * cairo_arc ]
+ [ cairo_close_path ]
+ [ 70.0 165.0 5.12 0 pi 2 * cairo_arc ]
+ [ cairo_fill ]
+ } cleave ;
+
+PRIVATE>
+
+M: cairo-demo-gadget graft* ( gadget -- )
+ dup dup init-cairo swap (>>cairo-t) draw-hello-world ;
+
+M: cairo-demo-gadget ungraft* ( gadget -- )
+ cairo-t>> cairo_destroy ;
+
+: <cairo-demo-gadget> ( -- gadget )
+ cairo-demo-gadget new-gadget ;
+
+: run ( -- )
+ [
+ <cairo-demo-gadget> "Hello World from Factor!" open-window
+ ] with-ui ;
+
+MAIN: run
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences math kernel byte-arrays cairo.ffi cairo
+io.backend ui.gadgets accessors opengl.gl arrays fry
+classes ui.render namespaces destructors libc ;
+IN: cairo.gadgets
+
+<PRIVATE
+: width>stride ( width -- stride ) 4 * ;
+
+: image-dims ( gadget -- width height stride )
+ dim>> first2 over width>stride ; inline
+: image-buffer ( width height stride -- alien )
+ * nip malloc ; inline
+PRIVATE>
+
+GENERIC: render-cairo* ( gadget -- )
+
+: render-cairo ( gadget -- alien )
+ [
+ image-dims
+ [ image-buffer dup CAIRO_FORMAT_ARGB32 ]
+ [ cairo_image_surface_create_for_data ] 3bi
+ ] [ '[ _ render-cairo* ] with-cairo-from-surface ] bi ;
+
+TUPLE: cairo-gadget < gadget ;
+
+: <cairo-gadget> ( dim -- gadget )
+ cairo-gadget new
+ swap >>dim ;
+
+M: cairo-gadget draw-gadget*
+ [
+ [ dim>> ] [ render-cairo &free ] bi
+ origin get first2 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ [ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip
+ glDrawPixels
+ ] with-destructors ;
+
+: copy-surface ( surface -- )
+ cr swap 0 0 cairo_set_source_surface
+ cr cairo_paint ;
--- /dev/null
+UI gadget for rendering graphics with Cairo
--- /dev/null
+! Copyright (C) 2008 Matthew Willis
+! See http://factorcode.org/license.txt for BSD license.
+!
+! these samples are a subset of the samples on
+! http://cairographics.org/samples/
+USING: cairo cairo.ffi locals math.constants math
+io.backend kernel alien.c-types libc namespaces
+cairo.gadgets ui.gadgets accessors specialized-arrays.double ;
+
+IN: cairo-samples
+
+TUPLE: arc-gadget < cairo-gadget ;
+M:: arc-gadget render-cairo* ( gadget -- )
+ [let | xc [ 128.0 ]
+ yc [ 128.0 ]
+ radius [ 100.0 ]
+ angle1 [ pi 1/4 * ]
+ angle2 [ pi ] |
+ cr 10.0 cairo_set_line_width
+ cr xc yc radius angle1 angle2 cairo_arc
+ cr cairo_stroke
+
+ ! draw helping lines
+ cr 1 0.2 0.2 0.6 cairo_set_source_rgba
+ cr 6.0 cairo_set_line_width
+
+ cr xc yc 10.0 0 2 pi * cairo_arc
+ cr cairo_fill
+
+ cr xc yc radius angle1 angle1 cairo_arc
+ cr xc yc cairo_line_to
+ cr xc yc radius angle2 angle2 cairo_arc
+ cr xc yc cairo_line_to
+ cr cairo_stroke
+ ] ;
+
+TUPLE: clip-gadget < cairo-gadget ;
+M: clip-gadget render-cairo* ( gadget -- )
+ drop
+ cr 128 128 76.8 0 2 pi * cairo_arc
+ cr cairo_clip
+ cr cairo_new_path
+
+ cr 0 0 256 256 cairo_rectangle
+ cr cairo_fill
+ cr 0 1 0 cairo_set_source_rgb
+ cr 0 0 cairo_move_to
+ cr 256 256 cairo_line_to
+ cr 256 0 cairo_move_to
+ cr 0 256 cairo_line_to
+ cr 10 cairo_set_line_width
+ cr cairo_stroke ;
+
+TUPLE: clip-image-gadget < cairo-gadget ;
+M:: clip-image-gadget render-cairo* ( gadget -- )
+ [let* | png [ "resource:misc/icons/Factor_128x128.png"
+ normalize-path cairo_image_surface_create_from_png ]
+ w [ png cairo_image_surface_get_width ]
+ h [ png cairo_image_surface_get_height ] |
+ cr 128 128 76.8 0 2 pi * cairo_arc
+ cr cairo_clip
+ cr cairo_new_path
+
+ cr 192.0 w / 192.0 h / cairo_scale
+ cr png 32 32 cairo_set_source_surface
+ cr cairo_paint
+ png cairo_surface_destroy
+ ] ;
+
+TUPLE: dash-gadget < cairo-gadget ;
+M:: dash-gadget render-cairo* ( gadget -- )
+ [let | dashes [ double-array{ 50 10 10 10 } underlying>> ]
+ ndash [ 4 ] |
+ cr dashes ndash -50 cairo_set_dash
+ cr 10 cairo_set_line_width
+ cr 128.0 25.6 cairo_move_to
+ cr 230.4 230.4 cairo_line_to
+ cr -102.4 0 cairo_rel_line_to
+ cr 51.2 230.4 51.2 128.0 128.0 128.0 cairo_curve_to
+ cr cairo_stroke
+ ] ;
+
+TUPLE: gradient-gadget < cairo-gadget ;
+M:: gradient-gadget render-cairo* ( gadget -- )
+ [let | pat [ 0 0 0 256 cairo_pattern_create_linear ]
+ radial [ 115.2 102.4 25.6 102.4 102.4 128.0
+ cairo_pattern_create_radial ] |
+ pat 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
+ pat 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
+ cr 0 0 256 256 cairo_rectangle
+ cr pat cairo_set_source
+ cr cairo_fill
+ pat cairo_pattern_destroy
+
+ radial 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
+ radial 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
+ cr radial cairo_set_source
+ cr 128.0 128.0 76.8 0 2 pi * cairo_arc
+ cr cairo_fill
+ radial cairo_pattern_destroy
+ ] ;
+
+TUPLE: text-gadget < cairo-gadget ;
+M: text-gadget render-cairo* ( gadget -- )
+ drop
+ cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
+ cairo_select_font_face
+ cr 50 cairo_set_font_size
+ cr 10 135 cairo_move_to
+ cr "Hello" cairo_show_text
+
+ cr 70 165 cairo_move_to
+ cr "factor" cairo_text_path
+ cr 0.5 0.5 1 cairo_set_source_rgb
+ cr cairo_fill_preserve
+ cr 0 0 0 cairo_set_source_rgb
+ cr 2.56 cairo_set_line_width
+ cr cairo_stroke
+
+ ! draw helping lines
+ cr 1 0.2 0.2 0.6 cairo_set_source_rgba
+ cr 10 135 5.12 0 2 pi * cairo_arc
+ cr cairo_close_path
+ cr 70 165 5.12 0 2 pi * cairo_arc
+ cr cairo_fill ;
+
+TUPLE: utf8-gadget < cairo-gadget ;
+M: utf8-gadget render-cairo* ( gadget -- )
+ drop
+ cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
+ cairo_select_font_face
+ cr 50 cairo_set_font_size
+ "cairo_text_extents_t" malloc-object
+ cr "日本語" pick cairo_text_extents
+ cr over
+ [ cairo_text_extents_t-width 2 / ]
+ [ cairo_text_extents_t-x_bearing ] bi +
+ 128 swap - pick
+ [ cairo_text_extents_t-height 2 / ]
+ [ cairo_text_extents_t-y_bearing ] bi +
+ 128 swap - cairo_move_to
+ free
+ cr "日本語" cairo_show_text
+
+ cr 1 0.2 0.2 0.6 cairo_set_source_rgba
+ cr 6 cairo_set_line_width
+ cr 128 0 cairo_move_to
+ cr 0 256 cairo_rel_line_to
+ cr 0 128 cairo_move_to
+ cr 256 0 cairo_rel_line_to
+ cr cairo_stroke ;
+
+ USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
+ : samples ( -- )
+ {
+ arc-gadget clip-gadget clip-image-gadget dash-gadget
+ gradient-gadget text-gadget utf8-gadget
+ }
+ [ new-gadget { 256 256 } >>dim gadget. ] each ;
+
+ MAIN: samples
--- /dev/null
+
+USING: kernel combinators sequences opengl.gl
+ ui.render ui.gadgets ui.gadgets.slate
+ accessors ;
+
+IN: ui.gadgets.cartesian
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: cartesian < slate x-min x-max y-min y-max z-min z-max perspective ;
+
+: init-cartesian ( cartesian -- cartesian )
+ init-slate
+ -10 >>x-min
+ 10 >>x-max
+ -10 >>y-min
+ 10 >>y-max
+ -1 >>z-min
+ 1 >>z-max ;
+
+: <cartesian> ( -- cartesian ) cartesian new init-cartesian ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: cartesian establish-coordinate-system ( cartesian -- cartesian )
+ dup
+ {
+ [ x-min>> ] [ x-max>> ]
+ [ y-min>> ] [ y-max>> ]
+ [ z-min>> ] [ z-max>> ]
+ }
+ cleave
+ glOrtho ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: x-range ( cartesian range -- cartesian ) first2 [ >>x-min ] [ >>x-max ] bi* ;
+: y-range ( cartesian range -- cartesian ) first2 [ >>y-min ] [ >>y-max ] bi* ;
+: z-range ( cartesian range -- cartesian ) first2 [ >>z-min ] [ >>z-max ] bi* ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel alien.c-types combinators namespaces make arrays
+ sequences splitting
+ math math.functions math.vectors math.trig
+ opengl.gl opengl.glu opengl ui ui.gadgets.slate
+ vars colors self self.slots
+ random-weighted colors.hsv cfdg.gl accessors
+ ui.gadgets.handler ui.gestures assocs ui.gadgets macros
+ specialized-arrays.double ;
+
+QUALIFIED: syntax
+
+IN: cfdg
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SELF-SLOTS: hsva
+
+: clear-color ( color -- ) gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! if (adjustment < 0)
+! base + base * adjustment
+
+! if (adjustment > 0)
+! base + (1 - base) * adjustment
+
+: adjust ( val num -- val ) dup 0 > [ 1 pick - * + ] [ dupd * + ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: hue ( num -- ) hue-> + 360 mod ->hue ;
+
+: saturation ( num -- ) saturation-> swap adjust ->saturation ;
+: brightness ( num -- ) value-> swap adjust ->value ;
+: alpha ( num -- ) alpha-> swap adjust ->alpha ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: h ( num -- ) hue ;
+: sat ( num -- ) saturation ;
+: b ( num -- ) brightness ;
+: a ( num -- ) alpha ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: color-stack
+
+: init-color-stack ( -- ) V{ } clone >color-stack ;
+
+: push-color ( -- ) self> color-stack> push self> clone >self ;
+
+: pop-color ( -- ) color-stack> pop dup >self gl-color ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ;
+
+: double-nth* ( c-array indices -- seq )
+ swap byte-array>double-array [ nth ] curry map ;
+
+: check-size ( modelview -- num ) { 0 1 4 5 } double-nth* [ abs ] map supremum ;
+
+VAR: threshold
+
+: iterate? ( -- ? ) get-modelview-matrix check-size threshold> > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! cos 2a sin 2a 0 0
+! sin 2a -cos 2a 0 0
+! 0 0 1 0
+! 0 0 0 1
+
+! column major order
+
+: gl-flip ( angle -- ) deg>rad dup dup dup
+ [ 2 * cos , 2 * sin , 0 , 0 ,
+ 2 * sin , 2 * cos neg , 0 , 0 ,
+ 0 , 0 , 1 , 0 ,
+ 0 , 0 , 0 , 1 , ]
+ double-array{ } make underlying>> glMultMatrixd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: circle ( -- )
+ self> gl-color
+ gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ;
+
+: triangle ( -- )
+ self> gl-color
+ GL_POLYGON glBegin
+ 0 0.577 glVertex2d
+ 0.5 -0.289 glVertex2d
+ -0.5 -0.289 glVertex2d
+ glEnd ;
+
+: square ( -- )
+ self> gl-color
+ GL_POLYGON glBegin
+ -0.5 0.5 glVertex2d
+ 0.5 0.5 glVertex2d
+ 0.5 -0.5 glVertex2d
+ -0.5 -0.5 glVertex2d
+ glEnd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: size ( scale -- ) dup 1 glScaled ;
+
+: size* ( scale-x scale-y -- ) 1 glScaled ;
+
+: rotate ( angle -- ) 0 0 1 glRotated ;
+
+: x ( x -- ) 0 0 glTranslated ;
+
+: y ( y -- ) 0 swap 0 glTranslated ;
+
+: flip ( angle -- ) gl-flip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: s ( scale -- ) size ;
+: s* ( scale-x scale-y -- ) size* ;
+: r ( angle -- ) rotate ;
+: f ( angle -- ) flip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: do ( quot -- )
+ push-modelview-matrix
+ push-color
+ call
+ pop-modelview-matrix
+ pop-color ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: recursive ( quot -- ) iterate? swap when ; inline
+
+: multi ( seq -- ) random-weighted* call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: [rules] ( seq -- quot )
+ [ unclip swap [ [ do ] curry ] map concat 2array ] map
+ [ call-random-weighted ] swap prefix
+ [ when ] swap prefix
+ [ iterate? ] swap append ;
+
+MACRO: rules ( seq -- quot ) [rules] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: [rule] ( seq -- quot )
+ [ [ do ] swap prefix ] map concat
+ [ when ] swap prefix
+ [ iterate? ] prepend ;
+
+MACRO: rule ( seq -- quot ) [rule] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: background
+
+: set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ;
+
+: set-background ( -- )
+ set-initial-background
+ background> call
+ self> clear-color ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: rewrite-closures ;
+
+VAR: viewport ! { left width bottom height }
+
+VAR: start-shape
+
+: set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: dlist
+
+! : build-model-dlist ( -- )
+! 1 glGenLists dlist set
+! dlist get GL_COMPILE_AND_EXECUTE glNewList
+! start-shape> call
+! glEndList ;
+
+: build-model-dlist ( -- )
+ 1 glGenLists dlist set
+ dlist get GL_COMPILE_AND_EXECUTE glNewList
+
+ set-initial-color
+
+ self> gl-color
+
+ start-shape> call
+
+ glEndList ;
+
+: display ( -- )
+
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ viewport> first dup viewport> second +
+ viewport> third dup viewport> fourth + gluOrtho2D
+
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity
+
+ set-background
+
+ GL_COLOR_BUFFER_BIT glClear
+
+ init-modelview-matrix-stack
+ init-color-stack
+
+ dlist get not
+ [ build-model-dlist ]
+ [ dlist get glCallList ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: delete-dlist ( -- ) dlist get [ dlist get 1 glDeleteLists dlist off ] when ;
+
+: cfdg-window* ( -- slate )
+ C[ display ] <slate>
+ { 500 500 } >>pdim
+ C[ delete-dlist ] >>ungraft
+ dup "CFDG" open-window ;
+
+: cfdg-window ( -- slate ) [ cfdg-window* ] with-ui ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: the-slate
+
+: rebuild ( -- ) delete-dlist the-slate get relayout-1 ;
+
+: <cfdg-gadget> ( -- slate )
+ C[ display ] <slate>
+ dup the-slate set
+ { 500 500 } >>pdim
+ C[ dlist get [ dlist get 1 glDeleteLists ] when ] >>ungraft
+ <handler>
+ H{ } clone
+ T{ key-down f f "ENTER" } C[ drop rebuild ] swap pick set-at
+ T{ button-down } C[ drop rebuild ] swap pick set-at
+ >>table ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: fry
+
+: cfdg-window. ( quot -- )
+ '[ [ @ <cfdg-gadget> "CFDG" open-window ] with-scope ] with-ui ;
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel alien.c-types namespaces sequences opengl.gl ;
+
+IN: cfdg.gl
+
+: get-modelview-matrix ( -- alien )
+ GL_MODELVIEW_MATRIX 16 "GLdouble" <c-array> tuck glGetDoublev ;
+
+SYMBOL: modelview-matrix-stack
+
+: init-modelview-matrix-stack ( -- ) V{ } clone modelview-matrix-stack set ;
+
+: push-modelview-matrix ( -- )
+ get-modelview-matrix modelview-matrix-stack get push ;
+
+: pop-modelview-matrix ( -- ) modelview-matrix-stack get pop glLoadMatrixd ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel namespaces math random opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.aqua-star
+
+: tentacle ( -- )
+iterate? [
+ { { 1 [ circle
+ [ .23 y .99 s .002 b tentacle ] do ] }
+ { 1 [ circle
+ [ .17 y 2 r .99 s .002 b tentacle ] do ] }
+ { 1 [ circle
+ [ .12 y -2 r .99 s .001 b tentacle ] do ] } }
+ call-random-weighted
+] when ;
+
+: anemone ( -- )
+iterate? [
+ tentacle
+ [ 10 x -11 r .995 s -.002 b anemone ] do
+] when ;
+
+: anemone-begin ( -- ) [ 196 hue 0.8324 sat 1 b anemone ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ -1 b ] >background
+ { -60 140 -120 140 } >viewport
+ 0.1 >threshold
+ [ anemone-begin ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces sequences math
+ opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.chiaroscuro
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: white
+
+: black ( -- )
+ {
+ { 60 [ 0.6 s circle ] [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] }
+ { 1 [ white black ] }
+ }
+ rules ;
+
+: white ( -- )
+ {
+ { 60 [ 0.6 s circle ] [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] }
+ { 1 [ black white ] }
+ }
+ rules ;
+
+: chiaroscuro ( -- ) { [ 0.5 b black ] } rule ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ -0.5 b ] >background
+ { -3 6 -2 6 } >viewport
+ 0.03 >threshold
+ [ chiaroscuro ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+USING: tools.deploy.config ;
+V{
+ { deploy-ui? t }
+ { deploy-io 1 }
+ { deploy-reflection 2 }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { "bundle-name" "cfdg.models.flower6.app" }
+}
--- /dev/null
+
+USING: kernel namespaces sequences math
+ opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.flower6
+
+: petal6 ( -- )
+iterate? [
+ [ 1 0.001 s* square ] do
+ [ -0.5 x 0.01 s -1 b circle ] do
+ [ 0.5 x 120.21 r 0.996 s 0.5 x 0.005 b petal6 ] do
+] when ;
+
+: flower6 ( -- )
+12 [ [ [ 30 r ] times petal6 ] do ] each
+12 [ [ [ 30 r ] times 90 flip petal6 ] do ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ ] >background
+ { -1 2 -1 2 } >viewport
+ 0.01 >threshold
+ [ flower6 ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
+
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.game1-turn6
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: f-triangles ( -- )
+ {
+ [ 0.1 x 0.1 y -0.33 alpha 20 hue 0.7 sat 0.80 b triangle ]
+ [ 10 hue 0.9 sat 0.33 b triangle ]
+ [ 0.9 s 10 hue 0.5 sat 1.00 b triangle ]
+ [ 0.8 s 5 r f-triangles ]
+ }
+ rule ;
+
+: f-squares ( -- )
+ {
+ [ 0.1 x 0.1 y -0.33 alpha 250 hue 0.70 sat 0.80 b square ]
+ [ 220 hue 0.90 sat 0.33 b square ]
+ [ 0.9 s 220 hue 0.25 sat 1.00 b square ]
+ [ 0.8 s 5 r f-squares ]
+ }
+ rule ;
+
+DEFER: start
+
+: spiral ( -- )
+ {
+ { 1 [ f-squares ]
+ [ 0.5 x 0.5 y 45 r f-triangles ]
+ [ 1 y 25 r 0.9 s spiral ] }
+
+ { 0.022 [ 90 flip 50 hue start ] }
+ }
+ rules ;
+
+: start ( -- )
+ [ spiral ] do
+ [ 120 r spiral ] do
+ [ 240 r spiral ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ 66 hue 0.4 sat 0.5 b ] >background
+ { -5 10 -5 10 } >viewport
+ 0.001 >threshold
+ [ start ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.lesson
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: shapes ( -- )
+[ square ] do
+[ 0.3 b circle ] do
+[ 0.5 b triangle ] do
+[ 0.7 b 60 r triangle ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chapter-1 ( -- )
+[ 2 x 5 y 3 size square ] do
+[ 6 x 5 y 3 size circle ] do
+[ 4 x 2 y 3 size triangle ] do
+[ 1 y 3 size shapes ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: foursquare ( -- )
+[ 0 x 0 y 5 3 size* square ] do
+[ 0 x 5 y 2 4 size* square ] do
+[ 5 x 5 y 3 size square ] do
+[ 5 x 0 y 2 size square ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chapter-2 ( -- )
+[ square ] do
+[ 3 x 7 y square ] do
+[ 5 x 7 y 30 r square ] do
+[ 3 x 5 y 0.75 size square ] do
+[ 5 x 5 y 0.5 b square ] do
+[ 7 x 6 y 45 r 0.7 size 0.7 b square ] do
+[ 5 x 1 y 10 r 0.2 size foursquare ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: spiral ( -- )
+iterate? [
+ [ 0.5 size circle ] do
+ [ 0.2 y -3 r 0.995 size spiral ] do
+] when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chapter-3 ( -- ) [ 0 x 3 y spiral ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: tree
+
+: branch-left ( -- )
+{ { 1 [ 20 r tree ] }
+ { 1 [ 30 r tree ] }
+ { 1 [ 40 r tree ] }
+ { 1 [ ] } } random-weighted* do ;
+
+: branch-right ( -- )
+{ { 1 [ -20 r tree ] }
+ { 1 [ -30 r tree ] }
+ { 1 [ -40 r tree ] }
+ { 1 [ ] } } random-weighted* do ;
+
+: branch ( -- ) branch-left branch-right ;
+
+: tree ( -- )
+iterate? [
+ {
+ { 20 [ [ 0.25 size circle ] do
+ [ 0.1 y 0.97 size tree ] do ] }
+ { 1.5 [ branch ] }
+ } random-weighted* do
+] when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chapter-4 ( -- )
+[ 1 x 0 y tree ] do
+[ 6 x 0 y tree ] do
+[ 1 x 4 y tree ] do
+[ 6 x 4 y tree ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: toc ( -- )
+[ 0 x 0 y chapter-1 ] do
+[ 10 x 0 y chapter-2 ] do
+[ 0 x -10 y chapter-3 ] do
+[ 10 x -10 y chapter-4 ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ ] >background
+ { -5 25 -15 25 } >viewport
+ 0.03 >threshold
+ [ toc ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
+
--- /dev/null
+
+USING: namespaces sequences math random-weighted cfdg ;
+
+IN: cfdg.models.rules08
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: insct ( -- )
+ [ 1.5 5.5 size* -1 brightness triangle ] do
+ 10
+ [ [ [ 1 0.9 size* -0.15 y 0.05 brightness ] times 1 5 size* triangle ] do ]
+ each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: line
+
+: ligne ( -- )
+ {
+ { 1 [ 4.5 y 1.15 0.8 size* -0.3 b line ] }
+ { 0.5 [ ] }
+ }
+ rules ;
+
+: line ( -- ) { [ insct ligne ] } rule ;
+
+: sole ( -- )
+ {
+ { 1 [ 1 brightness 0.5 saturation ligne ] [ 140 r 1 hue sole ] }
+ { 0.01 [ ] }
+ }
+ rules ;
+
+: centre ( -- ) { [ 1 b 5 s circle ] [ sole ] } rule ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ -1 b ] >background
+ { -20 40 -20 40 } viewport set
+ [ centre ] >start-shape
+ 0.0001 >threshold ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: run
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.sierpinski
+
+: shape ( -- ) circle ;
+
+! : sierpinski ( -- )
+! iterate? [
+! shape
+! [ 0.6 s 5 r 0.2 b -1.5 y 0 x sierpinski ] do
+! [ 0.6 s 5 r -0.2 b 0.75 y -1.2990375 x sierpinski ] do
+! [ 0.6 s 5 r 0.75 y 1.2990375 x sierpinski ] do
+! ] when ;
+
+: sierpinski ( -- )
+iterate? [
+ shape
+ [ -1.5 y 0 x 0.6 s 5 r 0.2 b sierpinski ] do
+ [ 0.75 y -1.2990375 x 0.6 s 5 r -0.2 b sierpinski ] do
+ [ 0.75 y 1.2990375 x 0.6 s 5 r sierpinski ] do
+] when ;
+
+: top ( -- ) [ -13.5 r 0.5 b sierpinski ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ ] >background
+ { -4 8 -4 8 } >viewport
+ 0.01 >threshold
+ [ top ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
+ random-weighted cfdg ;
+
+IN: cfdg.models.snowflake
+
+: spike ( -- )
+iterate? [
+ { { 1 [ square
+ [ 0.95 y 0.97 s spike ] do ] }
+ { 0.03 [ square
+ [ 60 r spike ] do
+ [ -60 r spike ] do
+ [ 0.95 y 0.97 s spike ] do ] } }
+ call-random-weighted
+] when ;
+
+: snowflake ( -- )
+spike
+[ 60 r spike ] do
+[ 120 r spike ] do
+[ 180 r spike ] do
+[ 240 r spike ] do
+[ 300 r spike ] do ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ ] >background
+ { -40 80 -40 80 } >viewport
+ 0.1 >threshold
+ [ snowflake ] >start-shape ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+MAIN: run
+
--- /dev/null
+
+USING: namespaces sequences math random-weighted cfdg ;
+
+IN: cfdg.models.spirales
+
+DEFER: line
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: block ( -- ) { [ circle ] [ 0.3 s 60 flip line ] } rule ;
+
+: a1 ( -- ) { [ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] [ block ] } rule ;
+
+: line ( -- ) -0.3 a { [ 0 r a1 ] [ 120 r a1 ] [ 240 r a1 ] } rule ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init ( -- )
+ [ -1 b ] >background
+ { -20 40 -20 40 } >viewport
+ [ line ] >start-shape
+ 0.04 >threshold ;
+
+: run ( -- ) [ init ] cfdg-window. ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: run
\ No newline at end of file
--- /dev/null
+Implementation of: http://contextfreeart.org
--- /dev/null
+
+USING: accessors alien.c-types combinators grouping kernel
+ locals math math.geometry.rect math.vectors opengl.gl sequences
+ ui.gadgets ui.render ;
+
+IN: frame-buffer
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <frame-buffer> < gadget pixels last-dim ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: update-frame-buffer ( <frame-buffer> -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-frame-buffer-pixels ( frame-buffer -- )
+ dup
+ rect-dim product "uint[4]" <c-array>
+ >>pixels
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: frame-buffer ( -- <frame-buffer> ) <frame-buffer> new-gadget ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: draw-pixels ( FRAME-BUFFER -- )
+
+ FRAME-BUFFER rect-dim first2
+ GL_RGBA
+ GL_UNSIGNED_INT
+ FRAME-BUFFER pixels>>
+ glDrawPixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: read-pixels ( FRAME-BUFFER -- )
+
+ 0
+ 0
+ FRAME-BUFFER rect-dim first2
+ GL_RGBA
+ GL_UNSIGNED_INT
+ FRAME-BUFFER pixels>>
+ glReadPixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: copy-row ( OLD NEW -- )
+
+ [let | LEN [ OLD NEW min-length ] |
+
+ OLD LEN head-slice 0 NEW copy ] ;
+
+: copy-pixels ( old-pixels old-width new-pixels new-width -- )
+ [ 16 * <sliced-groups> ] 2bi@
+ [ copy-row ] 2each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: update-last-dim ( frame-buffer -- ) dup rect-dim >>last-dim drop ;
+
+M:: <frame-buffer> layout* ( FRAME-BUFFER -- )
+
+ {
+ {
+ [ FRAME-BUFFER last-dim>> f = ]
+ [
+ FRAME-BUFFER init-frame-buffer-pixels
+
+ FRAME-BUFFER update-last-dim
+ ]
+ }
+ {
+ [ FRAME-BUFFER [ rect-dim ] [ last-dim>> ] bi = not ]
+ [
+ [let | OLD-PIXELS [ FRAME-BUFFER pixels>> ]
+ OLD-WIDTH [ FRAME-BUFFER last-dim>> first ] |
+
+ FRAME-BUFFER init-frame-buffer-pixels
+
+ FRAME-BUFFER update-last-dim
+
+ [let | NEW-PIXELS [ FRAME-BUFFER pixels>> ]
+ NEW-WIDTH [ FRAME-BUFFER last-dim>> first ] |
+
+ OLD-PIXELS OLD-WIDTH NEW-PIXELS NEW-WIDTH copy-pixels ] ]
+ ]
+ }
+ { [ t ] [ ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <frame-buffer> draw-gadget* ( FRAME-BUFFER -- )
+
+ FRAME-BUFFER rect-dim { 0 1 } v* first2 glRasterPos2i
+
+ FRAME-BUFFER draw-pixels
+
+ FRAME-BUFFER update-frame-buffer
+
+ glFlush
+
+ FRAME-BUFFER read-pixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+USING: tools.deploy.config ;
+V{
+ { deploy-ui? t }
+ { deploy-io 1 }
+ { deploy-reflection 1 }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { deploy-name "Golden Section" }
+}
--- /dev/null
+
+USING: kernel namespaces math math.constants math.functions math.order
+ arrays sequences
+ opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme
+ ui.gadgets.cartesian colors accessors combinators.cleave
+ processing.shapes ;
+
+IN: golden-section
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! omega(i) = 2*pi*i*(phi-1)
+
+! x(i) = 0.5*i*cos(omega(i))
+! y(i) = 0.5*i*sin(omega(i))
+
+! radius(i) = 10*sin((pi*i)/720)
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: omega ( i -- omega ) phi 1- * 2 * pi * ;
+
+: x ( i -- x ) [ omega cos ] [ 0.5 * ] bi * ;
+: y ( i -- y ) [ omega sin ] [ 0.5 * ] bi * ;
+
+: center ( i -- point ) { x y } 1arr ;
+
+: radius ( i -- radius ) pi * 720 / sin 10 * ;
+
+: color ( i -- i ) dup 360.0 / dup 0.25 1 rgba boa >fill-color ;
+
+: line-width ( i -- i ) dup radius 0.5 * 1 max glLineWidth ;
+
+: draw ( i -- ) [ center ] [ radius 1.5 * 2 * ] bi circle ;
+
+: dot ( i -- ) color line-width draw ;
+
+: golden-section ( -- ) 720 [ dot ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <golden-section> ( -- gadget )
+ <cartesian>
+ { 600 600 } >>pdim
+ { -400 400 } x-range
+ { -400 400 } y-range
+ [ golden-section ] >>action ;
+
+: golden-section-window ( -- )
+ [ <golden-section> "Golden Section" open-window ] with-ui ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: golden-section-window
--- /dev/null
+Golden section demo
--- /dev/null
+William Schlieper
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: kernel vocabs.loader sequences strings splitting words irc.messages ;\r
+\r
+IN: irc.ui.commandparser\r
+\r
+: command ( string string -- string command )\r
+ [ "say" ] when-empty\r
+ dup "irc.ui.commands" lookup\r
+ [ nip ]\r
+ [ " " append prepend "quote" "irc.ui.commands" lookup ] if* ;\r
+\r
+: parse-message ( string -- )\r
+ "/" ?head [ " " split1 swap command ] [ "say" command ] if execute ;\r
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: accessors kernel sequences arrays irc.client\r
+ irc.messages irc.ui namespaces ;\r
+\r
+IN: irc.ui.commands\r
+\r
+: say ( string -- )\r
+ irc-tab get\r
+ [ window>> client>> profile>> nickname>> <own-message> print-irc ]\r
+ [ chat>> speak ] 2bi ;\r
+\r
+: me ( string -- ) ! Placeholder until I make /me look different\r
+ "ACTION " 1 prefix prepend 1 suffix say ;\r
+\r
+: join ( string -- )\r
+ irc-tab get window>> join-channel ;\r
+\r
+: query ( string -- )\r
+ irc-tab get window>> query-nick ;\r
+\r
+: whois ( string -- )\r
+ "WHOIS" swap { } clone swap <irc-client-message>\r
+ irc-tab get listener>> speak ;\r
+\r
+: quote ( string -- )\r
+ drop ; ! THIS WILL CHANGE\r
--- /dev/null
+! Default system ircui-rc file\r
+! Copy into .ircui-rc in your home directory and then change username and such\r
+! To find your home directory, type "home ." into a Factor listener\r
+\r
+USING: irc.client irc.ui ;\r
+\r
+"irc.freenode.org" 8001 "factor-irc" f ! server port nick password\r
+{ "#concatenative" "#terrorisland" } ! all the channels you want to autojoin\r
+server-open\r
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: kernel io.files io.pathnames parser editors sequences ;\r
+\r
+IN: irc.ui.load\r
+\r
+: file-or ( path path -- path ) [ [ exists? ] keep ] dip ? ;\r
+\r
+: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;\r
+\r
+: system-ui-rc ( -- path ) "extra/irc/ui/ircui-rc" resource-path ;\r
+\r
+: ircui-rc ( -- path ) personal-ui-rc system-ui-rc file-or ;\r
+\r
+: run-ircui ( -- ) ircui-rc run-file ;\r
--- /dev/null
+A simple IRC client
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: accessors kernel threads combinators concurrency.mailboxes\r
+ sequences strings hashtables splitting fry assocs hashtables colors\r
+ sorting unicode.collation math.order\r
+ ui ui.gadgets ui.gadgets.panes ui.gadgets.editors\r
+ ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures\r
+ ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels\r
+ io io.styles namespaces calendar calendar.format models continuations\r
+ irc.client irc.client.private irc.messages\r
+ irc.ui.commandparser irc.ui.load vocabs.loader classes prettyprint ;\r
+\r
+RENAME: join sequences => sjoin\r
+\r
+IN: irc.ui\r
+\r
+SYMBOL: chat\r
+\r
+SYMBOL: client\r
+\r
+TUPLE: ui-window < tabbed client ;\r
+\r
+M: ui-window ungraft*\r
+ client>> terminate-irc ;\r
+\r
+TUPLE: irc-tab < frame chat client window ;\r
+\r
+: write-color ( str color -- )\r
+ foreground associate format ;\r
+CONSTANT: dark-red T{ rgba f 0.5 0.0 0.0 1 }\r
+CONSTANT: dark-green T{ rgba f 0.0 0.5 0.0 1 }\r
+CONSTANT: dark-blue T{ rgba f 0.0 0.0 0.5 1 }\r
+\r
+: dot-or-parens ( string -- string )\r
+ [ "." ]\r
+ [ "(" prepend ")" append ] if-empty ;\r
+\r
+GENERIC: write-irc ( irc-message -- )\r
+\r
+M: ping write-irc\r
+ drop "* Ping" blue write-color ;\r
+\r
+M: privmsg write-irc\r
+ "<" dark-blue write-color\r
+ [ irc-message-sender write ] keep\r
+ "> " dark-blue write-color\r
+ trailing>> write ;\r
+\r
+M: notice write-irc\r
+ [ type>> dark-blue write-color ] keep\r
+ ": " dark-blue write-color\r
+ trailing>> write ;\r
+\r
+TUPLE: own-message message nick timestamp ;\r
+\r
+: <own-message> ( message nick -- own-message )\r
+ now own-message boa ;\r
+\r
+M: own-message write-irc\r
+ "<" dark-blue write-color\r
+ [ nick>> bold font-style associate format ] keep\r
+ "> " dark-blue write-color\r
+ message>> write ;\r
+\r
+M: join write-irc\r
+ "* " dark-green write-color\r
+ irc-message-sender write\r
+ " has entered the channel." dark-green write-color ;\r
+\r
+M: part write-irc\r
+ "* " dark-red write-color\r
+ [ irc-message-sender write ] keep\r
+ " has left the channel" dark-red write-color\r
+ trailing>> dot-or-parens dark-red write-color ;\r
+\r
+M: quit write-irc\r
+ "* " dark-red write-color\r
+ [ irc-message-sender write ] keep\r
+ " has left IRC" dark-red write-color\r
+ trailing>> dot-or-parens dark-red write-color ;\r
+\r
+M: kick write-irc\r
+ "* " dark-red write-color\r
+ [ irc-message-sender write ] keep\r
+ " has kicked " dark-red write-color\r
+ [ who>> write ] keep\r
+ " from the channel" dark-red write-color\r
+ trailing>> dot-or-parens dark-red write-color ;\r
+\r
+M: mode write-irc\r
+ "* " dark-blue write-color\r
+ [ name>> write ] keep\r
+ " has applied mode " dark-blue write-color\r
+ [ mode>> write ] keep\r
+ " to " dark-blue write-color\r
+ parameter>> write ;\r
+\r
+M: nick write-irc\r
+ "* " dark-blue write-color\r
+ [ irc-message-sender write ] keep\r
+ " is now known as " blue write-color\r
+ trailing>> write ;\r
+\r
+M: unhandled write-irc\r
+ "UNHANDLED: " write\r
+ line>> dark-blue write-color ;\r
+\r
+M: irc-end write-irc\r
+ drop "* You have left IRC" dark-red write-color ;\r
+\r
+M: irc-disconnected write-irc\r
+ drop "* Disconnected" dark-red write-color ;\r
+\r
+M: irc-connected write-irc\r
+ drop "* Connected" dark-green write-color ;\r
+\r
+M: irc-chat-end write-irc\r
+ drop ;\r
+\r
+M: irc-message write-irc\r
+ "UNIMPLEMENTED" write\r
+ [ class pprint ] keep\r
+ ": " write\r
+ line>> dark-blue write-color ;\r
+\r
+GENERIC: time-happened ( message -- timestamp )\r
+\r
+M: irc-message time-happened timestamp>> ;\r
+\r
+M: object time-happened drop now ;\r
+\r
+: print-irc ( irc-message -- )\r
+ [ time-happened timestamp>hms write " " write ]\r
+ [ write-irc nl ] bi ;\r
+\r
+: send-message ( message -- )\r
+ [ print-irc ]\r
+ [ chat get speak ] bi ;\r
+\r
+GENERIC: handle-inbox ( tab message -- )\r
+\r
+: value-labels ( assoc val -- seq )\r
+ '[ nip _ = ] assoc-filter keys sort-strings [ <label> ] map ;\r
+\r
+: add-gadget-color ( pack seq color -- pack )\r
+ '[ _ >>color add-gadget ] each ;\r
+\r
+M: object handle-inbox\r
+ nip print-irc ;\r
+\r
+: display ( stream tab -- )\r
+ '[ _ [ [ t ]\r
+ [ _ dup chat>> hear handle-inbox ]\r
+ while ] with-output-stream ] "ircv" spawn drop ;\r
+\r
+: <irc-pane> ( tab -- tab pane )\r
+ <scrolling-pane>\r
+ [ <pane-stream> swap display ] 2keep ;\r
+\r
+TUPLE: irc-editor < editor outstream tab ;\r
+\r
+: <irc-editor> ( tab pane -- tab editor )\r
+ irc-editor new-editor\r
+ swap <pane-stream> >>outstream ;\r
+\r
+: editor-send ( irc-editor -- )\r
+ { [ outstream>> ]\r
+ [ [ irc-tab? ] find-parent ]\r
+ [ editor-string ]\r
+ [ "" swap set-editor-string ] } cleave\r
+ '[ _ irc-tab set _ parse-message ] with-output-stream ;\r
+\r
+irc-editor "general" f {\r
+ { T{ key-down f f "RET" } editor-send }\r
+ { T{ key-down f f "ENTER" } editor-send }\r
+} define-command-map\r
+\r
+: new-irc-tab ( chat ui-window class -- irc-tab )\r
+ new-frame\r
+ swap >>window\r
+ swap >>chat\r
+ <irc-pane> [ <scroller> @center grid-add ] keep\r
+ <irc-editor> <scroller> @bottom grid-add ;\r
+\r
+M: irc-tab graft*\r
+ [ chat>> ] [ window>> client>> ] bi attach-chat ;\r
+\r
+M: irc-tab ungraft*\r
+ chat>> detach-chat ;\r
+\r
+TUPLE: irc-channel-tab < irc-tab userlist ;\r
+\r
+: <irc-channel-tab> ( chat ui-window -- irc-tab )\r
+ irc-channel-tab new-irc-tab\r
+ <pile> [ <scroller> @right grid-add ] keep >>userlist ;\r
+\r
+: update-participants ( tab -- )\r
+ [ userlist>> [ clear-gadget ] keep ]\r
+ [ chat>> participants>> ] bi\r
+ [ +operator+ value-labels dark-green add-gadget-color ]\r
+ [ +voice+ value-labels blue add-gadget-color ]\r
+ [ +normal+ value-labels black add-gadget-color ] tri drop ;\r
+\r
+M: participant-changed handle-inbox\r
+ drop update-participants ;\r
+\r
+TUPLE: irc-server-tab < irc-tab ;\r
+\r
+: <irc-server-tab> ( chat -- irc-tab )\r
+ f irc-server-tab new-irc-tab ;\r
+\r
+: <irc-nick-tab> ( chat ui-window -- irc-tab )\r
+ irc-tab new-irc-tab ;\r
+\r
+M: irc-tab pref-dim*\r
+ drop { 480 480 } ;\r
+\r
+: join-channel ( name ui-window -- )\r
+ [ dup <irc-channel-chat> ] dip\r
+ [ <irc-channel-tab> swap ] keep\r
+ add-page ;\r
+\r
+: query-nick ( nick ui-window -- )\r
+ [ dup <irc-nick-chat> ] dip\r
+ [ <irc-nick-tab> swap ] keep\r
+ add-page ;\r
+\r
+: irc-window ( ui-window -- )\r
+ [ ]\r
+ [ client>> profile>> server>> ] bi\r
+ open-window ;\r
+\r
+: ui-connect ( profile -- ui-window )\r
+ <irc-client>\r
+ { [ [ <irc-server-chat> ] dip attach-chat ]\r
+ [ chats>> +server-chat+ swap at <irc-server-tab> dup\r
+ "Server" associate ui-window new-tabbed [ swap (>>window) ] keep ]\r
+ [ >>client ]\r
+ [ connect-irc ] } cleave ;\r
+\r
+: server-open ( server port nick password channels -- )\r
+ [ <irc-profile> ui-connect [ irc-window ] keep ] dip\r
+ [ over join-channel ] each drop ;\r
+\r
+: main-run ( -- ) run-ircui ;\r
+\r
+MAIN: main-run\r
+\r
+"irc.ui.commands" require\r
--- /dev/null
+
+USING: kernel accessors locals math math.intervals math.order
+ namespaces sequences threads
+ ui
+ ui.gadgets
+ ui.gestures
+ ui.render
+ calendar
+ multi-methods
+ multi-method-syntax
+ combinators.short-circuit.smart
+ combinators.cleave.enhanced
+ processing.shapes
+ flatland ;
+
+IN: pong
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431
+!
+! Which was based on this Nodebox version: http://billmill.org/pong.html
+! by Bill Mill.
+!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: clamp-to-interval ( x interval -- x )
+ [ from>> first max ] [ to>> first min ] bi ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <play-field> < <rectangle> ;
+TUPLE: <paddle> < <rectangle> ;
+
+TUPLE: <computer> < <paddle> { speed initial: 10 } ;
+
+: computer-move-left ( computer -- ) dup speed>> move-left-by ;
+: computer-move-right ( computer -- ) dup speed>> move-right-by ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <ball> < <vel>
+ { diameter initial: 20 }
+ { bounciness initial: 1.2 }
+ { max-speed initial: 10 } ;
+
+: above-lower-bound? ( ball field -- ? ) bottom 50 - above? ;
+: below-upper-bound? ( ball field -- ? ) top 50 + below? ;
+
+: in-bounds? ( ball field -- ? )
+ {
+ [ above-lower-bound? ]
+ [ below-upper-bound? ]
+ } && ;
+
+:: bounce-change-vertical-velocity ( BALL -- )
+
+ BALL vel>> y neg
+ BALL bounciness>> *
+
+ BALL max-speed>> min
+
+ BALL vel>> (y!) ;
+
+:: bounce-off-paddle ( BALL PADDLE -- )
+
+ BALL bounce-change-vertical-velocity
+
+ BALL x PADDLE center x - 0.25 * BALL vel>> (x!)
+
+ PADDLE top BALL pos>> (y!) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mouse-x ( -- x ) hand-loc get first ;
+
+:: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval )
+
+ PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ;
+
+:: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- )
+
+ mouse-x
+
+ PADDLE PLAY-FIELD valid-paddle-interval
+
+ clamp-to-interval
+
+ PADDLE pos>> (x!) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Protocol for drawing PONG objects
+
+GENERIC: draw ( obj -- )
+
+METHOD: draw ( <paddle> -- ) [ bottom-left ] [ dim>> ] bi rectangle ;
+METHOD: draw ( <ball> -- ) [ pos>> ] [ diameter>> 2 / ] bi circle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided
+ ! by multi-methods
+
+TUPLE: <pong> < gadget paused field ball player computer ;
+
+: pong ( -- gadget )
+ <pong> new-gadget
+ T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } clone >>field
+ T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } clone >>ball
+ T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } clone >>player
+ T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } clone >>computer ;
+
+M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
+M: <pong> ungraft* ( <pong> -- ) t >>paused drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <pong> draw-gadget* ( PONG -- )
+
+ PONG computer>> draw
+ PONG player>> draw
+ PONG ball>> draw ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-system ( GADGET -- )
+
+ [let | FIELD [ GADGET field>> ]
+ BALL [ GADGET ball>> ]
+ PLAYER [ GADGET player>> ]
+ COMPUTER [ GADGET computer>> ] |
+
+ [wlet | align-player-with-mouse [ ( -- )
+ PLAYER FIELD align-paddle-with-mouse ]
+
+ move-ball [ ( -- ) BALL 1 move-for ]
+
+ player-blocked-ball? [ ( -- ? )
+ BALL PLAYER { [ above? ] [ in-between-horizontally? ] } && ]
+
+ computer-blocked-ball? [ ( -- ? )
+ BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ]
+
+ bounce-off-wall? [ ( -- ? )
+ BALL FIELD in-between-horizontally? not ]
+
+ stop-game [ ( -- ) t GADGET (>>paused) ] |
+
+ BALL FIELD in-bounds?
+ [
+
+ align-player-with-mouse
+
+ move-ball
+
+ ! computer reaction
+
+ BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
+ BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
+
+ ! check if ball bounced off something
+
+ player-blocked-ball? [ BALL PLAYER bounce-off-paddle ] when
+ computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle ] when
+ bounce-off-wall? [ BALL reverse-horizontal-velocity ] when
+ ]
+ [ stop-game ]
+ if
+
+ ] ] ( gadget -- ) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-pong-thread ( GADGET -- )
+ f GADGET (>>paused)
+ [
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
+ if
+ ]
+ loop
+ ]
+ in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pong-window ( -- ) pong [ "PONG" open-window ] [ start-pong-thread ] bi ;
+
+: pong-main ( -- ) [ pong-window ] with-ui ;
+
+MAIN: pong-window
\ No newline at end of file
--- /dev/null
+
+USING: kernel namespaces arrays sequences grouping
+ alien.c-types
+ math math.vectors math.geometry.rect
+ opengl.gl opengl.glu opengl generalizations vars
+ combinators.cleave colors ;
+
+IN: processing.shapes
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: do-state ( mode quot -- ) swap glBegin call glEnd ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: fill-color
+VAR: stroke-color
+
+T{ rgba f 0 0 0 1 } stroke-color set-global
+T{ rgba f 1 1 1 1 } fill-color set-global
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fill-mode ( -- )
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ fill-color> gl-color ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: stroke-mode ( -- )
+ GL_FRONT_AND_BACK GL_LINE glPolygonMode
+ stroke-color> gl-color ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gl-vertex-2d ( vertex -- ) first2 glVertex2d ;
+
+: gl-vertices-2d ( vertices -- ) [ gl-vertex-2d ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: point* ( x y -- ) stroke-mode GL_POINTS [ glVertex2d ] do-state ;
+: point ( point -- ) stroke-mode GL_POINTS [ gl-vertex-2d ] do-state ;
+: points ( points -- ) stroke-mode GL_POINTS [ gl-vertices-2d ] do-state ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: line** ( x y x y -- )
+ stroke-mode GL_LINES [ glVertex2d glVertex2d ] do-state ;
+
+: line* ( a b -- ) stroke-mode GL_LINES [ [ gl-vertex-2d ] bi@ ] do-state ;
+
+: lines ( seq -- ) stroke-mode GL_LINES [ gl-vertices-2d ] do-state ;
+
+: line ( seq -- ) lines ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: line-strip ( seq -- ) stroke-mode GL_LINE_STRIP [ gl-vertices-2d ] do-state ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: triangles ( seq -- )
+ [ fill-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ]
+ [ stroke-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ] bi ;
+
+: triangle ( seq -- ) triangles ;
+
+: triangle* ( a b c -- ) 3array triangles ;
+
+: triangle** ( x y x y x y -- ) 6 narray 2 group triangles ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: polygon ( seq -- )
+ [ fill-mode GL_POLYGON [ gl-vertices-2d ] do-state ]
+ [ stroke-mode GL_POLYGON [ gl-vertices-2d ] do-state ] bi ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rectangle ( loc dim -- )
+ <rect>
+ { top-left top-right bottom-right bottom-left }
+ 1arr
+ polygon ;
+
+: rectangle* ( x y width height -- ) [ 2array ] 2bi@ rectangle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gl-translate-2d ( pos -- ) first2 0 glTranslated ;
+
+: gl-scale-2d ( xy -- ) first2 1 glScaled ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gl-ellipse ( center dim -- )
+ glPushMatrix
+ [ gl-translate-2d ] [ gl-scale-2d ] bi*
+ gluNewQuadric
+ dup 0 0.5 20 1 gluDisk
+ gluDeleteQuadric
+ glPopMatrix ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gl-get-line-width ( -- width )
+ GL_LINE_WIDTH 0 <double> tuck glGetDoublev *double ;
+
+: ellipse ( center dim -- )
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ [ stroke-color> gl-color gl-ellipse ]
+ [ fill-color> gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: circle ( center size -- ) dup 2array ellipse ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+! Copyright (C) 2009 Eduardo Cavazos
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax multiline ;
+IN: ui.gadgets.slate
+
+ARTICLE: "ui.gadgets.slate" "Slate gadget"
+{ $description "A gadget with an 'action' slot which should be set to a callable."}
+{ $heading "Example" }
+{ $code <" USING: processing.shapes ui.gadgets.slate ui.gadgets.panes ;
+[ { { 10 10 } { 50 30 } { 10 50 } } polygon fill-mode ] <slate>
+gadget."> } ;
+
+ABOUT: "ui.gadgets.slate"
--- /dev/null
+! Copyright (C) 2009 Eduardo Cavazos
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces opengl ui.render ui.gadgets accessors ;
+
+IN: ui.gadgets.slate
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: slate < gadget action pdim graft ungraft ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-slate ( slate -- slate )
+ init-gadget
+ [ ] >>action
+ { 200 200 } >>pdim
+ [ ] >>graft
+ [ ] >>ungraft ;
+
+: <slate> ( action -- slate )
+ slate new
+ init-slate
+ swap >>action ;
+
+M: slate pref-dim* ( slate -- dim ) pdim>> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: combinators arrays sequences math math.geometry
+ opengl.gl ui.gadgets.worlds ;
+
+: screen-y* ( gadget -- loc )
+ {
+ [ find-world height ]
+ [ screen-loc second ]
+ [ height ]
+ }
+ cleave
+ + - ;
+
+: screen-loc* ( gadget -- loc )
+ {
+ [ screen-loc first ]
+ [ screen-y* ]
+ }
+ cleave
+ 2array ;
+
+: setup-viewport ( gadget -- gadget )
+ dup
+ {
+ [ screen-loc* ]
+ [ dim>> ]
+ }
+ cleave
+ gl-viewport ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: default-coordinate-system ( gadget -- gadget )
+ dup
+ {
+ [ drop 0 ]
+ [ width 1 - ]
+ [ height 1 - ]
+ [ drop 0 ]
+ }
+ cleave
+ -1 1
+ glOrtho ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate graft* ( slate -- ) graft>> call ;
+M: slate ungraft* ( slate -- ) ungraft>> call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: establish-coordinate-system ( gadget -- gadget )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate establish-coordinate-system ( slate -- slate )
+ default-coordinate-system ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: draw-slate ( slate -- slate )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate draw-slate ( slate -- slate ) dup action>> call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate draw-gadget* ( slate -- )
+
+ GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity
+
+ establish-coordinate-system
+
+ GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity
+
+ setup-viewport
+
+ draw-slate
+
+ GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity
+ GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity
+
+ dup
+ find-world
+ ! The world coordinate system is a little wacky:
+ dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho
+ setup-viewport
+ drop
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces arrays sequences math math.vectors random
+ springies springies.ui ;
+
+IN: springies.models.2snake
+
+: model ( -- )
+
+{ } clone >nodes
+{ } clone >springs
+0.001 >time-slice
+gravity off
+
+1 19.0 328.0 0.0 0.0 1.0 1.0 mass
+2 36.0 328.0 0.0 0.0 1.0 1.0 mass
+3 54.0 328.0 0.0 0.0 1.0 1.0 mass
+4 72.0 328.0 0.0 0.0 1.0 1.0 mass
+5 90.0 328.0 0.0 0.0 1.0 1.0 mass
+6 108.0 328.0 0.0 0.0 1.0 1.0 mass
+7 126.0 328.0 0.0 0.0 1.0 1.0 mass
+8 144.0 328.0 0.0 0.0 1.0 1.0 mass
+9 162.0 328.0 0.0 0.0 1.0 1.0 mass
+10 180.0 328.0 0.0 0.0 1.0 1.0 mass
+11 198.0 328.0 0.0 0.0 1.0 1.0 mass
+12 216.0 328.0 0.0 0.0 1.0 1.0 mass
+13 234.0 328.0 0.0 0.0 1.0 1.0 mass
+14 252.0 328.0 0.0 0.0 1.0 1.0 mass
+15 270.0 328.0 0.0 0.0 1.0 1.0 mass
+16 288.0 328.0 0.0 0.0 1.0 1.0 mass
+17 306.0 328.0 0.0 0.0 1.0 1.0 mass
+18 324.0 328.0 0.0 0.0 1.0 1.0 mass
+19 342.0 328.0 0.0 0.0 1.0 1.0 mass
+20 360.0 328.0 0.0 0.0 1.0 1.0 mass
+21 378.0 328.0 0.0 0.0 1.0 1.0 mass
+22 396.0 328.0 0.0 0.0 1.0 1.0 mass
+23 414.0 328.0 0.0 0.0 1.0 1.0 mass
+24 432.0 328.0 0.0 0.0 1.0 1.0 mass
+25 450.0 328.0 0.0 0.0 1.0 1.0 mass
+26 468.0 328.0 0.0 0.0 1.0 1.0 mass
+27 504.0 328.0 0.0 0.0 1.0 1.0 mass
+28 486.0 328.0 0.0 0.0 1.0 1.0 mass
+29 522.0 328.0 0.0 0.0 1.0 1.0 mass
+30 540.0 328.0 0.0 0.0 1.0 1.0 mass
+31 558.0 328.0 0.0 0.0 1.0 1.0 mass
+32 576.0 328.0 0.0 0.0 1.0 1.0 mass
+33 594.0 328.0 0.0 0.0 1.0 1.0 mass
+34 612.0 328.0 0.0 0.0 1.0 1.0 mass
+35 630.0 328.0 0.0 0.0 1.0 1.0 mass
+1 1 2 200.0 1.500000 18.0 spng
+2 3 2 200.0 1.500000 18.0 spng
+3 3 4 200.0 1.500000 18.0 spng
+4 4 5 200.0 1.500000 18.0 spng
+5 5 6 200.0 1.500000 18.0 spng
+6 6 7 200.0 1.500000 18.0 spng
+7 7 8 200.0 1.500000 18.0 spng
+8 8 9 200.0 1.500000 18.0 spng
+9 9 10 200.0 1.500000 18.0 spng
+10 10 11 200.0 1.500000 18.0 spng
+11 11 12 200.0 1.500000 18.0 spng
+12 12 13 200.0 1.500000 18.0 spng
+13 13 14 200.0 1.500000 18.0 spng
+14 14 15 200.0 1.500000 18.0 spng
+15 15 16 200.0 1.500000 18.0 spng
+16 16 17 200.0 1.500000 18.0 spng
+17 17 18 200.0 1.500000 18.0 spng
+18 18 19 200.0 1.500000 18.0 spng
+19 19 20 200.0 1.500000 18.0 spng
+20 20 21 200.0 1.500000 18.0 spng
+21 21 22 200.0 1.500000 18.0 spng
+22 22 23 200.0 1.500000 18.0 spng
+23 23 24 200.0 1.500000 18.0 spng
+24 24 25 200.0 1.500000 18.0 spng
+25 25 26 200.0 1.500000 18.0 spng
+26 26 28 200.0 1.500000 18.0 spng
+27 28 27 200.0 1.500000 18.0 spng
+28 27 29 200.0 1.500000 18.0 spng
+29 29 30 200.0 1.500000 18.0 spng
+30 30 31 200.0 1.500000 18.0 spng
+31 31 32 200.0 1.500000 18.0 spng
+32 32 33 200.0 1.500000 18.0 spng
+33 33 34 200.0 1.500000 18.0 spng
+34 34 35 200.0 1.500000 18.0 spng
+35 1 3 200.0 1.500000 36.0 spng
+36 2 4 200.0 1.500000 36.0 spng
+37 3 5 200.0 1.500000 36.0 spng
+38 4 6 200.0 1.500000 36.0 spng
+39 5 7 200.0 1.500000 36.0 spng
+40 6 8 200.0 1.500000 36.0 spng
+41 7 9 200.0 1.500000 36.0 spng
+42 8 10 200.0 1.500000 36.0 spng
+43 9 11 200.0 1.500000 36.0 spng
+44 10 12 200.0 1.500000 36.0 spng
+45 11 13 200.0 1.500000 36.0 spng
+46 12 14 200.0 1.500000 36.0 spng
+47 13 15 200.0 1.500000 36.0 spng
+48 14 16 200.0 1.500000 36.0 spng
+49 15 17 200.0 1.500000 36.0 spng
+50 16 18 200.0 1.500000 36.0 spng
+51 17 19 200.0 1.500000 36.0 spng
+52 18 20 200.0 1.500000 36.0 spng
+53 19 21 200.0 1.500000 36.0 spng
+54 20 22 200.0 1.500000 36.0 spng
+55 21 23 200.0 1.500000 36.0 spng
+56 22 24 200.0 1.500000 36.0 spng
+57 23 25 200.0 1.500000 36.0 spng
+58 24 26 200.0 1.500000 36.0 spng
+59 25 28 200.0 1.500000 36.0 spng
+60 26 27 200.0 1.500000 36.0 spng
+61 28 29 200.0 1.500000 36.0 spng
+62 27 30 200.0 1.500000 36.0 spng
+63 29 31 200.0 1.500000 36.0 spng
+64 30 32 200.0 1.500000 36.0 spng
+65 31 33 200.0 1.500000 36.0 spng
+66 32 34 200.0 1.500000 36.0 spng
+67 33 35 200.0 1.500000 36.0 spng
+
+nodes> [ 400 random -200 + 400 random -200 + 2array swap set-node-vel ] each ;
+
+USING: threads ui ;
+
+: go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces arrays sequences threads math math.vectors
+ ui random springies springies.ui ;
+
+IN: springies.models.2x2snake
+
+: model ( -- )
+
+{ } clone >nodes
+{ } clone >springs
+0.002 >time-slice
+gravity off
+
+1 147.0 324.0 0.0 0.0 1.0 1.0 mass
+2 164.0 324.0 0.0 0.0 1.0 1.0 mass
+3 182.0 324.0 0.0 0.0 1.0 1.0 mass
+4 200.0 324.0 0.0 0.0 1.0 1.0 mass
+5 218.0 324.0 0.0 0.0 1.0 1.0 mass
+6 236.0 324.0 0.0 0.0 1.0 1.0 mass
+7 254.0 324.0 0.0 0.0 1.0 1.0 mass
+8 272.0 324.0 0.0 0.0 1.0 1.0 mass
+9 290.0 324.0 0.0 0.0 1.0 1.0 mass
+10 308.0 324.0 0.0 0.0 1.0 1.0 mass
+11 326.0 324.0 0.0 0.0 1.0 1.0 mass
+12 344.0 324.0 0.0 0.0 1.0 1.0 mass
+13 362.0 324.0 0.0 0.0 1.0 1.0 mass
+14 380.0 324.0 0.0 0.0 1.0 1.0 mass
+15 398.0 324.0 0.0 0.0 1.0 1.0 mass
+16 416.0 324.0 0.0 0.0 1.0 1.0 mass
+17 434.0 324.0 0.0 0.0 1.0 1.0 mass
+18 452.0 324.0 0.0 0.0 1.0 1.0 mass
+19 470.0 324.0 0.0 0.0 1.0 1.0 mass
+20 147.0 298.0 0.0 0.0 1.0 1.0 mass
+21 164.0 298.0 0.0 0.0 1.0 1.0 mass
+22 182.0 298.0 0.0 0.0 1.0 1.0 mass
+23 200.0 298.0 0.0 0.0 1.0 1.0 mass
+24 218.0 298.0 0.0 0.0 1.0 1.0 mass
+25 236.0 298.0 0.0 0.0 1.0 1.0 mass
+26 254.0 298.0 0.0 0.0 1.0 1.0 mass
+27 272.0 298.0 0.0 0.0 1.0 1.0 mass
+28 290.0 298.0 0.0 0.0 1.0 1.0 mass
+29 308.0 298.0 0.0 0.0 1.0 1.0 mass
+30 326.0 298.0 0.0 0.0 1.0 1.0 mass
+31 344.0 298.0 0.0 0.0 1.0 1.0 mass
+32 362.0 298.0 0.0 0.0 1.0 1.0 mass
+33 380.0 298.0 0.0 0.0 1.0 1.0 mass
+34 398.0 298.0 0.0 0.0 1.0 1.0 mass
+35 416.0 298.0 0.0 0.0 1.0 1.0 mass
+36 434.0 298.0 0.0 0.0 1.0 1.0 mass
+37 452.0 298.0 0.0 0.0 1.0 1.0 mass
+38 470.0 298.0 0.0 0.0 1.0 1.0 mass
+1 1 2 200.0 1.500000 18.0 spng
+2 3 2 200.0 1.500000 18.0 spng
+3 3 4 200.0 1.500000 18.0 spng
+4 4 5 200.0 1.500000 18.0 spng
+5 5 6 200.0 1.500000 18.0 spng
+6 6 7 200.0 1.500000 18.0 spng
+7 7 8 200.0 1.500000 18.0 spng
+8 8 9 200.0 1.500000 18.0 spng
+9 9 10 200.0 1.500000 18.0 spng
+10 10 11 200.0 1.500000 18.0 spng
+11 11 12 200.0 1.500000 18.0 spng
+12 12 13 200.0 1.500000 18.0 spng
+13 13 14 200.0 1.500000 18.0 spng
+14 14 15 200.0 1.500000 18.0 spng
+15 15 16 200.0 1.500000 18.0 spng
+16 16 17 200.0 1.500000 18.0 spng
+17 17 18 200.0 1.500000 18.0 spng
+18 18 19 200.0 1.500000 18.0 spng
+19 1 3 200.0 1.500000 36.0 spng
+20 2 4 200.0 1.500000 36.0 spng
+21 3 5 200.0 1.500000 36.0 spng
+22 4 6 200.0 1.500000 36.0 spng
+23 5 7 200.0 1.500000 36.0 spng
+24 6 8 200.0 1.500000 36.0 spng
+25 7 9 200.0 1.500000 36.0 spng
+26 8 10 200.0 1.500000 36.0 spng
+27 9 11 200.0 1.500000 36.0 spng
+28 10 12 200.0 1.500000 36.0 spng
+29 11 13 200.0 1.500000 36.0 spng
+30 12 14 200.0 1.500000 36.0 spng
+31 13 15 200.0 1.500000 36.0 spng
+32 14 16 200.0 1.500000 36.0 spng
+33 15 17 200.0 1.500000 36.0 spng
+34 16 18 200.0 1.500000 36.0 spng
+35 17 19 200.0 1.500000 36.0 spng
+36 20 21 200.0 1.500000 18.0 spng
+37 22 21 200.0 1.500000 18.0 spng
+38 22 23 200.0 1.500000 18.0 spng
+39 23 24 200.0 1.500000 18.0 spng
+40 24 25 200.0 1.500000 18.0 spng
+41 25 26 200.0 1.500000 18.0 spng
+42 26 27 200.0 1.500000 18.0 spng
+43 27 28 200.0 1.500000 18.0 spng
+44 28 29 200.0 1.500000 18.0 spng
+45 29 30 200.0 1.500000 18.0 spng
+46 30 31 200.0 1.500000 18.0 spng
+47 31 32 200.0 1.500000 18.0 spng
+48 32 33 200.0 1.500000 18.0 spng
+49 33 34 200.0 1.500000 18.0 spng
+50 34 35 200.0 1.500000 18.0 spng
+51 35 36 200.0 1.500000 18.0 spng
+52 36 37 200.0 1.500000 18.0 spng
+53 37 38 200.0 1.500000 18.0 spng
+54 20 22 200.0 1.500000 36.0 spng
+55 21 23 200.0 1.500000 36.0 spng
+56 22 24 200.0 1.500000 36.0 spng
+57 23 25 200.0 1.500000 36.0 spng
+58 24 26 200.0 1.500000 36.0 spng
+59 25 27 200.0 1.500000 36.0 spng
+60 26 28 200.0 1.500000 36.0 spng
+61 27 29 200.0 1.500000 36.0 spng
+62 28 30 200.0 1.500000 36.0 spng
+63 29 31 200.0 1.500000 36.0 spng
+64 30 32 200.0 1.500000 36.0 spng
+65 31 33 200.0 1.500000 36.0 spng
+66 32 34 200.0 1.500000 36.0 spng
+67 33 35 200.0 1.500000 36.0 spng
+68 34 36 200.0 1.500000 36.0 spng
+69 35 37 200.0 1.500000 36.0 spng
+70 36 38 200.0 1.500000 36.0 spng
+71 1 20 200.0 1.500000 26.0 spng
+72 2 21 200.0 1.500000 26.0 spng
+73 3 22 200.0 1.500000 26.0 spng
+74 4 23 200.0 1.500000 26.0 spng
+75 5 24 200.0 1.500000 26.0 spng
+76 25 6 200.0 1.500000 26.0 spng
+77 7 26 200.0 1.500000 26.0 spng
+78 27 8 200.0 1.500000 26.0 spng
+79 9 28 200.0 1.500000 26.0 spng
+80 29 10 200.0 1.500000 26.0 spng
+81 11 30 200.0 1.500000 26.0 spng
+82 31 12 200.0 1.500000 26.0 spng
+83 13 32 200.0 1.500000 26.0 spng
+84 33 14 200.0 1.500000 26.0 spng
+85 15 34 200.0 1.500000 26.0 spng
+86 35 16 200.0 1.500000 26.0 spng
+87 17 36 200.0 1.500000 26.0 spng
+88 37 18 200.0 1.500000 26.0 spng
+89 19 38 200.0 1.500000 26.0 spng
+90 1 21 200.0 1.500000 31.064449 spng
+91 2 20 200.0 1.500000 31.064449 spng
+92 2 22 200.0 1.500000 31.622777 spng
+93 3 21 200.0 1.500000 31.622777 spng
+94 3 23 200.0 1.500000 31.622777 spng
+95 4 22 200.0 1.500000 31.622777 spng
+96 4 24 200.0 1.500000 31.622777 spng
+97 5 23 200.0 1.500000 31.622777 spng
+98 5 25 200.0 1.500000 31.622777 spng
+99 6 24 200.0 1.500000 31.622777 spng
+100 6 26 200.0 1.500000 31.622777 spng
+101 7 25 200.0 1.500000 31.622777 spng
+102 7 27 200.0 1.500000 31.622777 spng
+103 8 26 200.0 1.500000 31.622777 spng
+104 8 28 200.0 1.500000 31.622777 spng
+105 9 27 200.0 1.500000 31.622777 spng
+106 9 29 200.0 1.500000 31.622777 spng
+107 10 28 200.0 1.500000 31.622777 spng
+108 10 30 200.0 1.500000 31.622777 spng
+109 11 29 200.0 1.500000 31.622777 spng
+110 11 31 200.0 1.500000 31.622777 spng
+111 12 30 200.0 1.500000 31.622777 spng
+112 12 32 200.0 1.500000 31.622777 spng
+113 13 31 200.0 1.500000 31.622777 spng
+114 13 33 200.0 1.500000 31.622777 spng
+115 14 32 200.0 1.500000 31.622777 spng
+116 14 34 200.0 1.500000 31.622777 spng
+117 15 33 200.0 1.500000 31.622777 spng
+118 15 35 200.0 1.500000 31.622777 spng
+119 16 34 200.0 1.500000 31.622777 spng
+120 16 36 200.0 1.500000 31.622777 spng
+121 17 35 200.0 1.500000 31.622777 spng
+122 17 37 200.0 1.500000 31.622777 spng
+123 18 36 200.0 1.500000 31.622777 spng
+124 18 38 200.0 1.500000 31.622777 spng
+125 19 37 200.0 1.500000 31.622777 spng
+126 1 22 200.0 1.500000 43.600459 spng
+127 3 20 200.0 1.500000 43.600459 spng
+128 2 23 200.0 1.500000 44.407207 spng
+129 4 21 200.0 1.500000 44.407207 spng
+130 3 24 200.0 1.500000 44.407207 spng
+131 5 22 200.0 1.500000 44.407207 spng
+132 4 25 200.0 1.500000 44.407207 spng
+133 6 23 200.0 1.500000 44.407207 spng
+134 5 26 200.0 1.500000 44.407207 spng
+135 7 24 200.0 1.500000 44.407207 spng
+136 6 27 200.0 1.500000 44.407207 spng
+137 8 25 200.0 1.500000 44.407207 spng
+138 7 28 200.0 1.500000 44.407207 spng
+139 9 26 200.0 1.500000 44.407207 spng
+140 8 29 200.0 1.500000 44.407207 spng
+141 10 27 200.0 1.500000 44.407207 spng
+142 9 30 200.0 1.500000 44.407207 spng
+143 11 28 200.0 1.500000 44.407207 spng
+144 10 31 200.0 1.500000 44.407207 spng
+145 12 29 200.0 1.500000 44.407207 spng
+146 11 32 200.0 1.500000 44.407207 spng
+147 13 30 200.0 1.500000 44.407207 spng
+148 12 33 200.0 1.500000 44.407207 spng
+149 14 31 200.0 1.500000 44.407207 spng
+150 13 34 200.0 1.500000 44.407207 spng
+151 15 33 200.0 1.500000 31.622777 spng
+152 32 15 200.0 1.500000 44.407207 spng
+153 14 35 200.0 1.500000 44.407207 spng
+154 16 33 200.0 1.500000 44.407207 spng
+155 15 36 200.0 1.500000 44.407207 spng
+156 34 17 200.0 1.500000 44.407207 spng
+157 16 37 200.0 1.500000 44.407207 spng
+158 18 35 200.0 1.500000 44.407207 spng
+159 17 38 200.0 1.500000 44.407207 spng
+160 19 36 200.0 1.500000 44.407207 spng
+
+! Send the half of the snake in a random direction
+
+nodes> 10 [ swap nth ] with map
+nodes> 10 [ 19 + swap nth ] with map append
+100 random -50 + 100 random 100 + { -1 1 } random * 2array
+[ swap set-node-vel ] curry
+each ;
+
+: go ( -- ) [ model ] go* ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-compiler? t }
+ { deploy-word-props? f }
+ { deploy-ui? t }
+ { deploy-reflection 1 }
+ { deploy-name "springies.models.2x2snake" }
+ { deploy-c-types? f }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-math? t }
+ { deploy-io 1 }
+}
--- /dev/null
+
+USING: kernel namespaces arrays sequences threads math ui random fry
+ springies springies.ui ;
+
+IN: springies.models.3snake
+
+: random-range ( a b -- n ) 1+ over - random + ;
+
+: model ( -- )
+
+{ } clone >nodes
+{ } clone >springs
+0.001 >time-slice
+gravity off
+
+1 19.0 328.0 0.0 0.0 1.0 1.0 mass
+2 36.0 328.0 0.0 0.0 1.0 1.0 mass
+3 54.0 328.0 0.0 0.0 1.0 1.0 mass
+4 72.0 328.0 0.0 0.0 1.0 1.0 mass
+5 90.0 328.0 0.0 0.0 1.0 1.0 mass
+6 108.0 328.0 0.0 0.0 1.0 1.0 mass
+7 126.0 328.0 0.0 0.0 1.0 1.0 mass
+8 144.0 328.0 0.0 0.0 1.0 1.0 mass
+9 162.0 328.0 0.0 0.0 1.0 1.0 mass
+10 180.0 328.0 0.0 0.0 1.0 1.0 mass
+11 198.0 328.0 0.0 0.0 1.0 1.0 mass
+12 216.0 328.0 0.0 0.0 1.0 1.0 mass
+13 234.0 328.0 0.0 0.0 1.0 1.0 mass
+14 252.0 328.0 0.0 0.0 1.0 1.0 mass
+15 270.0 328.0 0.0 0.0 1.0 1.0 mass
+16 288.0 328.0 0.0 0.0 1.0 1.0 mass
+17 306.0 328.0 0.0 0.0 1.0 1.0 mass
+18 324.0 328.0 0.0 0.0 1.0 1.0 mass
+19 342.0 328.0 0.0 0.0 1.0 1.0 mass
+20 360.0 328.0 0.0 0.0 1.0 1.0 mass
+21 378.0 328.0 0.0 0.0 1.0 1.0 mass
+22 396.0 328.0 0.0 0.0 1.0 1.0 mass
+23 414.0 328.0 0.0 0.0 1.0 1.0 mass
+24 432.0 328.0 0.0 0.0 1.0 1.0 mass
+25 450.0 328.0 0.0 0.0 1.0 1.0 mass
+26 468.0 328.0 0.0 0.0 1.0 1.0 mass
+27 504.0 328.0 0.0 0.0 1.0 1.0 mass
+28 486.0 328.0 0.0 0.0 1.0 1.0 mass
+29 522.0 328.0 0.0 0.0 1.0 1.0 mass
+30 540.0 328.0 0.0 0.0 1.0 1.0 mass
+31 558.0 328.0 0.0 0.0 1.0 1.0 mass
+32 576.0 328.0 0.0 0.0 1.0 1.0 mass
+33 594.0 328.0 0.0 0.0 1.0 1.0 mass
+34 612.0 328.0 0.0 0.0 1.0 1.0 mass
+35 626.0 328.0 0.0 0.0 1.0 1.0 mass
+1 1 2 200.0 1.500000 18.0 spng
+2 3 2 200.0 1.500000 18.0 spng
+3 3 4 200.0 1.500000 18.0 spng
+4 4 5 200.0 1.500000 18.0 spng
+5 5 6 200.0 1.500000 18.0 spng
+6 6 7 200.0 1.500000 18.0 spng
+7 7 8 200.0 1.500000 18.0 spng
+8 8 9 200.0 1.500000 18.0 spng
+9 9 10 200.0 1.500000 18.0 spng
+10 10 11 200.0 1.500000 18.0 spng
+11 11 12 200.0 1.500000 18.0 spng
+12 12 13 200.0 1.500000 18.0 spng
+13 13 14 200.0 1.500000 18.0 spng
+14 14 15 200.0 1.500000 18.0 spng
+15 15 16 200.0 1.500000 18.0 spng
+16 16 17 200.0 1.500000 18.0 spng
+17 17 18 200.0 1.500000 18.0 spng
+18 18 19 200.0 1.500000 18.0 spng
+19 19 20 200.0 1.500000 18.0 spng
+20 20 21 200.0 1.500000 18.0 spng
+21 21 22 200.0 1.500000 18.0 spng
+22 22 23 200.0 1.500000 18.0 spng
+23 23 24 200.0 1.500000 18.0 spng
+24 24 25 200.0 1.500000 18.0 spng
+25 25 26 200.0 1.500000 18.0 spng
+26 26 28 200.0 1.500000 18.0 spng
+27 28 27 200.0 1.500000 18.0 spng
+28 27 29 200.0 1.500000 18.0 spng
+29 29 30 200.0 1.500000 18.0 spng
+30 30 31 200.0 1.500000 18.0 spng
+31 31 32 200.0 1.500000 18.0 spng
+32 32 33 200.0 1.500000 18.0 spng
+33 33 34 200.0 1.500000 18.0 spng
+34 34 35 200.0 1.500000 18.0 spng
+35 1 3 200.0 1.500000 36.0 spng
+36 2 4 200.0 1.500000 36.0 spng
+37 3 5 200.0 1.500000 36.0 spng
+38 4 6 200.0 1.500000 36.0 spng
+39 5 7 200.0 1.500000 36.0 spng
+40 6 8 200.0 1.500000 36.0 spng
+41 7 9 200.0 1.500000 36.0 spng
+42 8 10 200.0 1.500000 36.0 spng
+43 9 11 200.0 1.500000 36.0 spng
+44 10 12 200.0 1.500000 36.0 spng
+45 11 13 200.0 1.500000 36.0 spng
+46 12 14 200.0 1.500000 36.0 spng
+47 13 15 200.0 1.500000 36.0 spng
+48 14 16 200.0 1.500000 36.0 spng
+49 15 17 200.0 1.500000 36.0 spng
+50 16 18 200.0 1.500000 36.0 spng
+51 17 19 200.0 1.500000 36.0 spng
+52 18 20 200.0 1.500000 36.0 spng
+53 19 21 200.0 1.500000 36.0 spng
+54 20 22 200.0 1.500000 36.0 spng
+55 21 23 200.0 1.500000 36.0 spng
+56 22 24 200.0 1.500000 36.0 spng
+57 23 25 200.0 1.500000 36.0 spng
+58 24 26 200.0 1.500000 36.0 spng
+59 25 28 200.0 1.500000 36.0 spng
+60 26 27 200.0 1.500000 36.0 spng
+61 28 29 200.0 1.500000 36.0 spng
+62 27 30 200.0 1.500000 36.0 spng
+63 29 31 200.0 1.500000 36.0 spng
+64 30 32 200.0 1.500000 36.0 spng
+65 31 33 200.0 1.500000 36.0 spng
+66 32 34 200.0 1.500000 36.0 spng
+67 33 35 200.0 1.500000 36.0 spng
+68 1 4 200.0 1.500000 53.0 spng
+69 2 5 200.0 1.500000 54.0 spng
+70 3 6 200.0 1.500000 54.0 spng
+71 4 7 200.0 1.500000 54.0 spng
+72 5 8 200.0 1.500000 54.0 spng
+73 6 9 200.0 1.500000 54.0 spng
+74 7 10 200.0 1.500000 54.0 spng
+75 8 11 200.0 1.500000 54.0 spng
+76 9 12 200.0 1.500000 54.0 spng
+77 10 13 200.0 1.500000 54.0 spng
+78 11 14 200.0 1.500000 54.0 spng
+79 12 15 200.0 1.500000 54.0 spng
+80 13 16 200.0 1.500000 54.0 spng
+81 14 17 200.0 1.500000 54.0 spng
+82 15 18 200.0 1.500000 54.0 spng
+83 16 19 200.0 1.500000 54.0 spng
+84 17 20 200.0 1.500000 54.0 spng
+85 18 21 200.0 1.500000 54.0 spng
+86 19 22 200.0 1.500000 54.0 spng
+87 20 23 200.0 1.500000 54.0 spng
+88 21 24 200.0 1.500000 54.0 spng
+89 22 25 200.0 1.500000 54.0 spng
+90 23 26 200.0 1.500000 54.0 spng
+91 24 28 200.0 1.500000 54.0 spng
+92 25 27 200.0 1.500000 54.0 spng
+93 26 29 200.0 1.500000 54.0 spng
+94 28 30 200.0 1.500000 54.0 spng
+95 27 31 200.0 1.500000 54.0 spng
+96 29 32 200.0 1.500000 54.0 spng
+97 30 33 200.0 1.500000 54.0 spng
+98 31 34 200.0 1.500000 54.0 spng
+99 32 35 200.0 1.500000 50.0 spng
+
+10
+[
+ -400 400 random-range -400 400 random-range 2array
+ nodes> random
+ set-node-vel
+]
+times
+
+;
+
+! : go* ( quot -- )
+! [ [ [ springies-window* 1000 sleep % ] with-scope ] with-ui ] bake call ;
+
+: go* ( quot -- ) '[ [ springies-window* 1000 sleep @ ] with-scope ] with-ui ;
+
+! : go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ;
+
+: go ( -- ) [ model ] go* ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces sequences springies springies.ui ;
+
+IN: springies.models.ball
+
+: model ( -- )
+
+{ } clone >nodes
+{ } clone >springs
+0.01 >time-slice
+gravity on
+
+1 325.191871 140.872641 40.832215 -5.301529 1.0 1.0 mass
+2 313.933994 149.011616 55.240875 5.026852 1.0 1.0 mass
+3 309.133386 162.523019 72.798059 5.594199 1.0 1.0 mass
+4 312.887152 176.436760 83.754277 -1.370025 1.0 1.0 mass
+5 321.660596 187.895952 91.634021 -8.308630 1.0 1.0 mass
+6 335.256132 192.503856 94.772924 -18.985044 1.0 1.0 mass
+7 348.254504 188.731936 92.657963 -29.982110 1.0 1.0 mass
+8 359.050972 180.780059 86.668616 -39.817638 1.0 1.0 mass
+9 363.685639 167.752177 76.554871 -47.987107 1.0 1.0 mass
+10 360.449954 154.092353 57.992242 -48.045772 1.0 1.0 mass
+11 352.201411 142.382665 41.200547 -39.924209 1.0 1.0 mass
+12 338.754859 137.460615 32.306364 -22.707784 1.0 1.0 mass
+13 312.911184 114.835962 8.342965 5.878311 1.0 1.0 mass
+14 290.521818 132.872407 33.212103 28.391710 1.0 1.0 mass
+15 281.048450 160.314206 66.319674 32.935324 1.0 1.0 mass
+16 287.450075 188.730522 93.898071 21.966741 1.0 1.0 mass
+17 305.987715 211.206959 112.571044 5.089593 1.0 1.0 mass
+18 333.289699 220.830317 121.166705 -17.204713 1.0 1.0 mass
+19 361.089678 214.901909 117.183695 -41.776506 1.0 1.0 mass
+20 382.690515 197.005784 101.789802 -63.980298 1.0 1.0 mass
+21 392.095364 170.108402 75.453780 -78.414351 1.0 1.0 mass
+22 386.286391 142.033621 41.812216 -77.402424 1.0 1.0 mass
+23 368.355658 119.326317 12.658676 -58.885262 1.0 1.0 mass
+24 341.159901 109.253775 -0.645459 -27.346079 1.0 1.0 mass
+25 300.792976 88.652764 -23.770230 17.788258 1.0 1.0 mass
+26 266.917041 116.942125 11.387083 52.603190 1.0 1.0 mass
+27 252.824303 157.992984 59.144863 62.163730 1.0 1.0 mass
+28 261.812599 201.245775 103.542171 47.141708 1.0 1.0 mass
+29 290.323965 234.792944 133.016945 18.136362 1.0 1.0 mass
+30 330.805232 249.331769 145.899409 -16.478401 1.0 1.0 mass
+31 373.715232 241.181453 141.068680 -55.103677 1.0 1.0 mass
+32 406.314817 213.217096 116.087430 -90.844012 1.0 1.0 mass
+33 420.647493 172.661774 73.304028 -110.880720 1.0 1.0 mass
+34 412.375908 129.697207 24.072484 -106.129512 1.0 1.0 mass
+35 384.555754 95.915740 -16.565355 -77.142380 1.0 1.0 mass
+36 344.134757 80.886540 -34.250916 -30.871105 1.0 1.0 mass
+37 288.774590 62.672780 -55.431084 28.821437 1.0 1.0 mass
+38 244.055965 100.457489 -9.756397 76.701354 1.0 1.0 mass
+39 224.574635 156.693148 53.845562 91.755892 1.0 1.0 mass
+40 235.856891 213.935639 112.462316 73.437061 1.0 1.0 mass
+41 273.697931 257.991035 152.320671 33.701056 1.0 1.0 mass
+42 329.129445 277.782400 170.727571 -15.899371 1.0 1.0 mass
+43 386.065290 267.474982 165.436658 -68.761273 1.0 1.0 mass
+44 429.946314 229.605765 132.087682 -116.795195 1.0 1.0 mass
+45 449.164590 174.189613 73.084826 -143.228528 1.0 1.0 mass
+46 438.674101 117.351918 9.340834 -136.225613 1.0 1.0 mass
+47 401.586435 72.955570 -42.523445 -98.317857 1.0 1.0 mass
+48 346.207804 52.561279 -67.447974 -34.980297 1.0 1.0 mass
+1 1 2 150.0 2.0 14.0 spng
+2 2 3 150.0 2.0 14.0 spng
+3 3 4 150.0 2.0 14.0 spng
+4 4 5 150.0 2.0 14.0 spng
+5 5 6 150.0 2.0 14.0 spng
+6 6 7 150.0 2.0 14.0 spng
+7 7 8 150.0 2.0 14.0 spng
+8 8 9 150.0 2.0 14.0 spng
+9 9 10 150.0 2.0 14.0 spng
+10 10 11 150.0 2.0 14.0 spng
+11 11 12 150.0 2.0 14.0 spng
+12 12 1 150.0 2.0 14.0 spng
+13 13 14 150.0 2.0 28.0 spng
+14 14 15 150.0 2.0 28.0 spng
+15 15 16 150.0 2.0 28.0 spng
+16 16 17 150.0 2.0 28.0 spng
+17 17 18 150.0 2.0 28.0 spng
+18 18 19 150.0 2.0 28.0 spng
+19 19 20 150.0 2.0 28.0 spng
+20 20 21 150.0 2.0 28.0 spng
+21 21 22 150.0 2.0 28.0 spng
+22 22 23 150.0 2.0 28.0 spng
+23 23 24 150.0 2.0 28.0 spng
+24 24 13 150.0 2.0 28.0 spng
+25 25 26 150.0 2.0 44.0 spng
+26 26 27 150.0 2.0 43.0 spng
+27 27 28 150.0 2.0 44.0 spng
+28 28 29 150.0 2.0 44.0 spng
+29 29 30 150.0 2.0 43.0 spng
+30 30 31 150.0 2.0 44.0 spng
+31 31 32 150.0 2.0 43.0 spng
+32 32 33 150.0 2.0 43.0 spng
+33 33 34 150.0 2.0 44.0 spng
+34 34 35 150.0 2.0 44.0 spng
+35 35 36 150.0 2.0 43.0 spng
+36 36 25 150.0 2.0 44.0 spng
+37 37 38 150.0 2.0 58.0 spng
+38 38 39 150.0 2.0 59.0 spng
+39 39 40 150.0 2.0 58.0 spng
+40 40 41 150.0 2.0 58.0 spng
+41 41 42 150.0 2.0 59.0 spng
+42 42 43 150.0 2.0 58.0 spng
+43 43 44 150.0 2.0 58.0 spng
+44 44 45 150.0 2.0 59.0 spng
+45 45 46 150.0 2.0 58.0 spng
+46 46 47 150.0 2.0 58.0 spng
+47 47 48 150.0 2.0 59.0 spng
+48 48 37 150.0 2.0 58.0 spng
+49 1 13 150.0 2.0 29.0 spng
+50 2 14 150.0 2.0 28.0 spng
+51 3 15 150.0 2.0 28.0 spng
+52 4 16 150.0 2.0 29.0 spng
+53 5 17 150.0 2.0 28.0 spng
+54 6 18 150.0 2.0 28.0 spng
+55 7 19 150.0 2.0 29.0 spng
+56 8 20 150.0 2.0 28.0 spng
+57 9 21 150.0 2.0 28.0 spng
+58 10 22 150.0 2.0 29.0 spng
+59 11 23 150.0 2.0 28.0 spng
+60 12 24 150.0 2.0 28.0 spng
+61 13 25 150.0 2.0 29.0 spng
+62 14 26 150.0 2.0 28.0 spng
+63 15 27 150.0 2.0 28.0 spng
+64 16 28 150.0 2.0 29.0 spng
+65 17 29 150.0 2.0 28.0 spng
+66 18 30 150.0 2.0 28.0 spng
+67 19 31 150.0 2.0 29.0 spng
+68 20 32 150.0 2.0 28.0 spng
+69 21 33 150.0 2.0 28.0 spng
+70 22 34 150.0 2.0 29.0 spng
+71 23 35 150.0 2.0 28.0 spng
+72 24 36 150.0 2.0 28.0 spng
+73 25 37 150.0 2.0 29.0 spng
+74 26 38 150.0 2.0 28.0 spng
+75 27 39 150.0 2.0 28.0 spng
+76 28 40 150.0 2.0 29.0 spng
+77 29 41 150.0 2.0 28.0 spng
+78 30 42 150.0 2.0 28.0 spng
+79 31 43 150.0 2.0 29.0 spng
+80 32 44 150.0 2.0 28.0 spng
+81 33 45 150.0 2.0 28.0 spng
+82 34 46 150.0 2.0 29.0 spng
+83 35 47 150.0 2.0 28.0 spng
+84 36 48 150.0 2.0 28.0 spng
+85 1 14 150.0 2.0 35.0 spng
+86 2 15 150.0 2.0 35.0 spng
+87 3 16 150.0 2.0 34.0 spng
+88 4 17 150.0 2.0 35.0 spng
+89 5 18 150.0 2.0 35.0 spng
+90 6 19 150.0 2.0 34.0 spng
+91 7 20 150.0 2.0 35.0 spng
+92 8 21 150.0 2.0 35.0 spng
+93 9 22 150.0 2.0 34.0 spng
+94 10 23 150.0 2.0 35.0 spng
+95 11 24 150.0 2.0 35.0 spng
+96 12 13 150.0 2.0 34.0 spng
+97 13 26 150.0 2.0 46.0 spng
+98 14 27 150.0 2.0 45.0 spng
+99 15 28 150.0 2.0 45.0 spng
+100 16 29 150.0 2.0 46.0 spng
+101 17 30 150.0 2.0 45.0 spng
+102 18 31 150.0 2.0 45.0 spng
+103 19 32 150.0 2.0 45.0 spng
+104 20 33 150.0 2.0 45.0 spng
+105 21 34 150.0 2.0 45.0 spng
+106 22 35 150.0 2.0 46.0 spng
+107 23 36 150.0 2.0 45.0 spng
+108 24 25 150.0 2.0 45.0 spng
+109 25 38 150.0 2.0 58.0 spng
+110 26 39 150.0 2.0 58.0 spng
+111 27 40 150.0 2.0 58.0 spng
+112 28 41 150.0 2.0 58.0 spng
+113 29 42 150.0 2.0 58.0 spng
+114 30 43 150.0 2.0 58.0 spng
+115 31 44 150.0 2.0 58.0 spng
+116 32 45 150.0 2.0 58.0 spng
+117 33 46 150.0 2.0 58.0 spng
+118 34 47 150.0 2.0 58.0 spng
+119 35 48 150.0 2.0 58.0 spng
+120 36 37 150.0 2.0 58.0 spng
+121 1 24 150.0 2.0 35.0 spng
+122 2 13 150.0 2.0 34.0 spng
+123 3 14 150.0 2.0 35.0 spng
+124 4 15 150.0 2.0 35.0 spng
+125 5 16 150.0 2.0 34.0 spng
+126 6 17 150.0 2.0 35.0 spng
+127 7 18 150.0 2.0 35.0 spng
+128 8 19 150.0 2.0 34.0 spng
+129 9 20 150.0 2.0 35.0 spng
+130 10 21 150.0 2.0 35.0 spng
+131 11 22 150.0 2.0 34.0 spng
+132 12 23 150.0 2.0 35.0 spng
+133 13 36 150.0 2.0 46.0 spng
+134 14 25 150.0 2.0 45.0 spng
+135 15 26 150.0 2.0 45.0 spng
+136 16 27 150.0 2.0 46.0 spng
+137 17 28 150.0 2.0 45.0 spng
+138 18 29 150.0 2.0 45.0 spng
+139 19 30 150.0 2.0 46.0 spng
+140 20 31 150.0 2.0 45.0 spng
+141 21 32 150.0 2.0 45.0 spng
+142 22 33 150.0 2.0 46.0 spng
+143 23 34 150.0 2.0 45.0 spng
+144 24 35 150.0 2.0 45.0 spng
+145 25 48 150.0 2.0 58.0 spng
+146 26 37 150.0 2.0 58.0 spng
+147 27 38 150.0 2.0 58.0 spng
+148 28 39 150.0 2.0 58.0 spng
+149 29 40 150.0 2.0 58.0 spng
+150 30 41 150.0 2.0 58.0 spng
+151 31 42 150.0 2.0 58.0 spng
+152 32 43 150.0 2.0 58.0 spng
+153 33 44 150.0 2.0 58.0 spng
+154 34 45 150.0 2.0 58.0 spng
+155 35 46 150.0 2.0 58.0 spng
+156 36 47 150.0 2.0 58.0 spng
+157 10 4 150.0 2.0 52.331631 spng
+158 7 1 150.0 2.0 52.436772 spng
+159 12 6 150.0 2.0 54.680698 spng
+160 5 11 150.0 2.0 54.589379 spng
+161 9 3 150.0 2.0 54.451569 spng
+162 2 8 150.0 2.0 54.482231 spng
+163 45 11 150.0 2.0 101.408150 spng
+164 46 12 150.0 2.0 101.542452 spng
+165 47 1 150.0 2.0 101.963064 spng
+166 48 2 150.0 2.0 101.517329 spng
+167 37 3 150.0 2.0 101.603694 spng
+168 38 4 150.0 2.0 102.014031 spng
+169 39 5 150.0 2.0 101.547660 spng
+170 40 6 150.0 2.0 101.573762 spng
+171 41 7 150.0 2.0 101.897300 spng
+172 42 8 150.0 2.0 101.497982 spng
+173 43 9 150.0 2.0 101.870594 spng
+174 44 10 150.0 2.0 102.043753 spng
+175 45 11 150.0 2.0 101.408150 spng
+176 46 8 150.0 2.0 101.548938 spng
+177 47 10 150.0 2.0 90.645939 spng
+178 48 10 150.0 2.0 101.952119 spng
+179 37 11 150.0 2.0 101.552352 spng
+180 38 12 150.0 2.0 101.491447 spng
+181 39 1 150.0 2.0 101.971524 spng
+182 40 2 150.0 2.0 101.587400 spng
+183 41 3 150.0 2.0 101.519279 spng
+184 42 4 150.0 2.0 101.976181 spng
+185 43 5 150.0 2.0 101.714570 spng
+186 44 6 150.0 2.0 101.388747 spng
+187 45 7 150.0 2.0 101.773286 spng
+
+nodes> [ { 0 100 } swap set-node-vel ] each ;
+
+USING: threads ui ;
+
+: go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces arrays sequences threads math ui random
+ springies springies.ui ;
+
+IN: springies.models.belt-tire
+
+: model ( -- )
+
+{ } clone >nodes
+{ } clone >springs
+0.008 >time-slice
+gravity on
+
+1 274.078806900597328 346.307117178664043 0 0 1 0.5 mass
+2 284.142891110742823 329.83402842231834 0 0 1 0.5 mass
+3 295.307158356938658 355.695013578746227 0 0 1 0.5 mass
+4 300.698527801927128 337.003548930923216 0 0 1 0.5 mass
+5 318.093036910029696 359.203044347904552 0 0 1 0.5 mass
+6 318.542098798246286 339.592403450546044 0 0 1 0.5 mass
+7 340.949296214486822 356.831259237330983 0 0 1 0.5 mass
+8 336.494524828869885 337.754019325244656 0 0 1 0.5 mass
+9 362.534986907234952 348.770558940029559 0 0 1 0.5 mass
+10 353.491265306914897 331.642140359094469 0 0 1 0.5 mass
+11 381.368850422101502 335.37878701564847 0 0 1 0.5 mass
+12 368.085531061140216 321.055018811315335 0 0 1 0.5 mass
+13 396.117634938806759 317.519287773537314 0 0 1 0.5 mass
+14 379.675208211408915 307.277961968837246 0 0 1 0.5 mass
+15 405.655157991023771 296.391903048606025 0 0 1 0.5 mass
+16 387.124676448692242 290.862310093183567 0 0 1 0.5 mass
+17 409.337178964708642 273.594658653786666 0 0 1 0.5 mass
+18 389.76569804010461 273.012494879567555 0 0 1 0.5 mass
+19 407.11203230551871 250.712646124396059 0 0 1 0.5 mass
+20 387.966228461346304 255.061007930370067 0 0 1 0.5 mass
+21 399.188308328902735 229.098161823607285 0 0 1 0.5 mass
+22 381.896222954111181 238.073977723246998 0 0 1 0.5 mass
+23 385.883224011375262 210.148208473511374 0 0 1 0.5 mass
+24 371.614761646970464 223.279700317395225 0 0 1 0.5 mass
+25 367.955378160003875 195.334436550727929 0 0 1 0.5 mass
+26 357.817091674528911 211.717360072075536 0 0 1 0.5 mass
+27 346.743525482831387 185.884698478394085 0 0 1 0.5 mass
+28 341.291169697238729 204.55711005838188 0 0 1 0.5 mass
+29 323.935265230381788 182.330460182137188 0 0 1 0.5 mass
+30 323.466187791799882 201.937076877994031 0 0 1 0.5 mass
+31 301.04141769400843 184.703602685435726 0 0 1 0.5 mass
+32 305.532794735419941 203.763859300438838 0 0 1 0.5 mass
+33 279.442362700896183 192.851996602076866 0 0 1 0.5 mass
+34 288.551113492738239 209.893932668644339 0 0 1 0.5 mass
+35 260.65997798024199 206.334196608396638 0 0 1 0.5 mass
+36 273.960657978745814 220.516324161880476 0 0 1 0.5 mass
+37 246.029909853431349 224.197583023911335 0 0 1 0.5 mass
+38 262.719165304227545 234.58428660123181 0 0 1 0.5 mass
+39 236.458142984593252 245.235572499606377 0 0 1 0.5 mass
+40 254.870454491934908 250.81914136861181 0 0 1 0.5 mass
+41 232.703447579492519 268.042376651164432 0 0 1 0.5 mass
+42 252.226120754560156 268.679895159358864 0 0 1 0.5 mass
+43 234.96767702938331 291.007702051922024 0 0 1 0.5 mass
+44 254.040589506795527 286.621843971355872 0 0 1 0.5 mass
+45 242.759412026738119 312.577114225657738 0 0 1 0.5 mass
+46 260.111088599530603 303.593264087352964 0 0 1 0.5 mass
+47 256.101782779606651 331.52509923420655 0 0 1 0.5 mass
+48 270.373388641766439 318.366074596339615 0 0 1 0.5 mass
+49 320.448537383965288 270.292364746678743 0 0 10 0.5 mass
+1 1 4 200 2 28.284271247461902 spng
+2 4 5 200 2 28.284271247461902 spng
+3 5 8 200 2 28.284271247461902 spng
+4 8 9 200 2 28.284271247461902 spng
+5 9 12 200 2 28.284271247461902 spng
+6 12 13 200 2 28.284271247461902 spng
+7 13 16 200 2 28.284271247461902 spng
+8 16 17 200 2 28.284271247461902 spng
+9 17 20 200 2 28.284271247461902 spng
+10 20 21 200 2 28.284271247461902 spng
+11 21 24 200 2 28.284271247461902 spng
+12 24 25 200 2 28.284271247461902 spng
+13 25 28 200 2 28.284271247461902 spng
+14 28 29 200 2 28.284271247461902 spng
+15 29 32 200 2 28.284271247461902 spng
+16 32 33 200 2 28.284271247461902 spng
+17 33 36 200 2 28.284271247461902 spng
+18 36 37 200 2 28.284271247461902 spng
+19 37 40 200 2 28.284271247461902 spng
+20 40 41 200 2 28.284271247461902 spng
+21 41 44 200 2 28.284271247461902 spng
+22 44 45 200 2 28.284271247461902 spng
+23 45 48 200 2 28.284271247461902 spng
+24 3 6 200 2 28.284271247461902 spng
+25 7 10 200 2 28.284271247461902 spng
+26 11 14 200 2 28.284271247461902 spng
+27 15 18 200 2 28.284271247461902 spng
+28 19 22 200 2 28.284271247461902 spng
+29 23 26 200 2 28.284271247461902 spng
+30 27 30 200 2 28.284271247461902 spng
+31 31 34 200 2 28.284271247461902 spng
+32 35 38 200 2 28.284271247461902 spng
+33 39 44 200 2 44.7213595499957961 spng
+34 39 42 200 2 28.284271247461902 spng
+35 43 46 200 2 28.284271247461902 spng
+36 47 46 200 2 28.284271247461902 spng
+37 43 42 200 2 28.284271247461902 spng
+38 39 38 200 2 28.284271247461902 spng
+39 35 34 200 2 28.284271247461902 spng
+40 2 3 200 2 28.284271247461902 spng
+41 6 7 200 2 28.284271247461902 spng
+42 10 11 200 2 28.284271247461902 spng
+43 14 15 200 2 28.284271247461902 spng
+44 18 19 200 2 28.284271247461902 spng
+45 22 23 200 2 28.284271247461902 spng
+46 26 27 200 2 28.284271247461902 spng
+47 30 31 200 2 28.284271247461902 spng
+48 1 6 200 2 44.7213595499957961 spng
+49 3 8 200 2 44.7213595499957961 spng
+50 5 10 200 2 44.7213595499957961 spng
+51 7 12 200 2 44.7213595499957961 spng
+52 9 14 200 2 44.7213595499957961 spng
+53 11 16 200 2 44.7213595499957961 spng
+54 13 18 200 2 44.7213595499957961 spng
+55 15 20 200 2 44.7213595499957961 spng
+56 17 22 200 2 44.7213595499957961 spng
+57 19 24 200 2 44.7213595499957961 spng
+58 21 26 200 2 44.7213595499957961 spng
+59 23 28 200 2 44.7213595499957961 spng
+60 25 30 200 2 44.7213595499957961 spng
+61 27 32 200 2 44.7213595499957961 spng
+62 29 34 200 2 44.7213595499957961 spng
+63 31 36 200 2 44.7213595499957961 spng
+64 33 38 200 2 44.7213595499957961 spng
+65 35 40 200 2 44.7213595499957961 spng
+66 37 42 200 2 44.7213595499957961 spng
+67 41 46 200 2 44.7213595499957961 spng
+68 43 48 200 2 44.7213595499957961 spng
+69 2 5 200 2 44.7213595499957961 spng
+70 4 7 200 2 44.7213595499957961 spng
+71 6 9 200 2 44.7213595499957961 spng
+72 8 11 200 2 44.7213595499957961 spng
+73 10 13 200 2 44.7213595499957961 spng
+74 12 15 200 2 44.7213595499957961 spng
+75 14 17 200 2 44.7213595499957961 spng
+76 16 19 200 2 44.7213595499957961 spng
+77 18 21 200 2 44.7213595499957961 spng
+78 20 23 200 2 44.7213595499957961 spng
+79 22 25 200 2 44.7213595499957961 spng
+80 24 27 200 2 44.7213595499957961 spng
+81 26 29 200 2 44.7213595499957961 spng
+82 28 31 200 2 44.7213595499957961 spng
+83 30 33 200 2 44.7213595499957961 spng
+84 32 35 200 2 44.7213595499957961 spng
+85 34 37 200 2 44.7213595499957961 spng
+86 36 39 200 2 44.7213595499957961 spng
+87 38 41 200 2 44.7213595499957961 spng
+88 40 43 200 2 44.7213595499957961 spng
+89 42 45 200 2 44.7213595499957961 spng
+90 44 47 200 2 44.7213595499957961 spng
+91 1 8 200 2 63.2455532033675851 spng
+92 3 10 200 2 63.2455532033675851 spng
+93 5 12 200 2 63.2455532033675851 spng
+94 7 14 200 2 63.2455532033675851 spng
+95 9 16 200 2 63.2455532033675851 spng
+96 11 18 200 2 63.2455532033675851 spng
+97 13 20 200 2 63.2455532033675851 spng
+98 15 22 200 2 63.2455532033675851 spng
+99 17 24 200 2 63.2455532033675851 spng
+100 19 26 200 2 63.2455532033675851 spng
+101 21 28 200 2 63.2455532033675851 spng
+102 23 30 200 2 63.2455532033675851 spng
+103 25 32 200 2 63.2455532033675851 spng
+104 27 34 200 2 63.2455532033675851 spng
+105 29 36 200 2 63.2455532033675851 spng
+106 31 38 200 2 63.2455532033675851 spng
+107 33 40 200 2 63.2455532033675851 spng
+108 35 42 200 2 63.2455532033675851 spng
+109 37 44 200 2 63.2455532033675851 spng
+110 39 46 200 2 63.2455532033675851 spng
+111 48 41 200 2 63.2455532033675851 spng
+112 2 7 200 2 63.2455532033675851 spng
+113 4 9 200 2 63.2455532033675851 spng
+114 6 11 200 2 63.2455532033675851 spng
+115 8 13 200 2 63.2455532033675851 spng
+116 10 15 200 2 63.2455532033675851 spng
+117 12 17 200 2 63.2455532033675851 spng
+118 14 19 200 2 63.2455532033675851 spng
+119 16 21 200 2 63.2455532033675851 spng
+120 18 23 200 2 63.2455532033675851 spng
+121 20 25 200 2 63.2455532033675851 spng
+122 22 27 200 2 63.2455532033675851 spng
+123 24 29 200 2 63.2455532033675851 spng
+124 26 31 200 2 63.2455532033675851 spng
+125 28 33 200 2 63.2455532033675851 spng
+126 30 35 200 2 63.2455532033675851 spng
+127 32 37 200 2 63.2455532033675851 spng
+128 34 39 200 2 63.2455532033675851 spng
+129 36 41 200 2 63.2455532033675851 spng
+130 38 43 200 2 63.2455532033675851 spng
+131 40 45 200 2 63.2455532033675851 spng
+132 42 47 200 2 63.2455532033675851 spng
+133 1 3 200 2 20 spng
+134 3 5 200 2 20 spng
+135 5 7 200 2 20 spng
+136 7 9 200 2 20 spng
+137 9 11 200 2 20 spng
+138 11 13 200 2 20 spng
+139 13 15 200 2 20 spng
+140 15 17 200 2 20 spng
+141 17 19 200 2 20 spng
+142 19 21 200 2 20 spng
+143 21 23 200 2 20 spng
+144 23 25 200 2 20 spng
+145 25 27 200 2 20 spng
+146 27 29 200 2 20 spng
+147 29 31 200 2 20 spng
+148 31 33 200 2 20 spng
+149 33 35 200 2 20 spng
+150 35 37 200 2 20 spng
+151 37 39 200 2 20 spng
+152 39 41 200 2 20 spng
+153 41 43 200 2 20 spng
+154 43 45 200 2 20 spng
+155 45 47 200 2 20 spng
+156 2 4 200 2 20 spng
+157 4 6 200 2 20 spng
+158 6 8 200 2 20 spng
+159 8 10 200 2 20 spng
+160 10 12 200 2 20 spng
+161 12 14 200 2 20 spng
+162 14 16 200 2 20 spng
+163 16 18 200 2 20 spng
+164 18 20 200 2 20 spng
+165 20 22 200 2 20 spng
+166 22 24 200 2 20 spng
+167 24 26 200 2 20 spng
+168 26 28 200 2 20 spng
+169 28 30 200 2 20 spng
+170 30 32 200 2 20 spng
+171 32 34 200 2 20 spng
+172 34 36 200 2 20 spng
+173 36 38 200 2 20 spng
+174 38 40 200 2 20 spng
+175 40 42 200 2 20 spng
+176 42 44 200 2 20 spng
+177 44 46 200 2 20 spng
+178 46 48 200 2 20 spng
+179 1 2 200 2 20 spng
+180 3 4 200 2 20 spng
+181 5 6 200 2 20 spng
+182 7 8 200 2 20 spng
+183 9 10 200 2 20 spng
+184 11 12 200 2 20 spng
+185 13 14 200 2 20 spng
+186 15 16 200 2 20 spng
+187 17 18 200 2 20 spng
+188 19 20 200 2 20 spng
+189 21 22 200 2 20 spng
+190 23 24 200 2 20 spng
+191 25 26 200 2 20 spng
+192 27 28 200 2 20 spng
+193 29 30 200 2 20 spng
+194 31 32 200 2 20 spng
+195 33 34 200 2 20 spng
+196 35 36 200 2 20 spng
+197 37 38 200 2 20 spng
+198 39 40 200 2 20 spng
+199 41 42 200 2 20 spng
+200 43 44 200 2 20 spng
+201 45 46 200 2 20 spng
+202 47 48 200 2 20 spng
+203 47 2 200 2 28.284271247461902 spng
+204 1 48 200 2 28.284271247461902 spng
+205 1 46 200 2 44.7213595499957961 spng
+206 1 44 200 2 63.2455532033675851 spng
+207 47 4 200 2 44.7213595499957961 spng
+208 48 3 200 2 44.7213595499957961 spng
+209 47 6 200 2 63.2455532033675851 spng
+210 48 5 200 2 63.2455532033675851 spng
+211 46 3 200 2 63.2455532033675851 spng
+212 45 4 200 2 63.2455532033675851 spng
+213 47 1 200 2 20 spng
+214 48 2 200 2 20 spng
+215 18 49 300 3 69.2603782836911677 spng
+216 49 20 300 3 69.050706006528273 spng
+217 22 49 300 3 69.3541635375988079 spng
+218 49 24 300 3 69.5269731830747872 spng
+219 26 49 300 3 69.6347614342147381 spng
+220 49 28 300 3 68.9492567037527948 spng
+221 30 49 300 3 68.2641926635040477 spng
+222 49 32 300 3 68.0661443009665419 spng
+223 34 49 300 3 68.4470598345904051 spng
+224 49 36 300 3 68.1175454637056106 spng
+225 38 49 300 3 67.6756972627545252 spng
+226 49 40 300 3 68.6221538571910514 spng
+227 42 49 300 3 68.1835757349231386 spng
+228 49 44 300 3 68.249542123006222 spng
+229 46 49 300 3 68.8767014308902503 spng
+230 49 48 300 3 69.4262198308391305 spng
+231 2 49 300 3 69.8927750200262068 spng
+232 49 4 300 3 69.5701085237043486 spng
+233 6 49 300 3 69.1809222257119103 spng
+234 8 49 300 3 69.2314957226839027 spng
+235 49 10 300 3 69.7782200976780445 spng
+236 12 49 300 3 69.5269731830747872 spng
+237 49 14 300 3 69.8927750200262068 spng
+238 16 49 300 3 69.8927750200262068 spng
+
+
+nodes> 200 random -100 + 100 2array [ swap set-node-vel ] curry each ;
+
+: go ( -- ) [ model ] go* ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+USING: tools.deploy.config ;
+V{
+ { deploy-ui? t }
+ { deploy-io 2 }
+ { deploy-reflection 1 }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { "bundle-name" "Belt Tire.app" }
+}
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces arrays sequences threads math math.vectors
+ ui random springies springies.ui ;
+
+IN: springies.models.nifty
+
+: model ( -- )
+
+{ } clone >nodes
+{ } clone >springs
+0.007 >time-slice
+gravity off
+
+1 148.581450999999987 350.573888000000011 0 -7.75 1 0.1 mass
+2 168.564277000000004 351.402524000000028 0 -7.75 1 0.1 mass
+3 188.54710399999999 352.231158999999991 0 -7.75 1 0.1 mass
+4 208.529931000000005 353.059794000000011 0 -7.75 1 0.1 mass
+5 228.512757999999991 353.888428999999974 0 -7.75 1 0.1 mass
+6 248.495584000000008 354.717063999999993 0 -7.75 1 0.1 mass
+7 149.410086000000007 330.591061000000025 0 -7.75 1 0.1 mass
+8 150.238720999999998 310.608234999999979 0 -7.75 1 0.1 mass
+9 151.06735599999999 290.625407999999993 0 -7.75 1 0.1 mass
+10 151.895991000000009 270.642581000000007 0 -7.75 1 0.1 mass
+11 152.724626000000001 250.65975499999999 0 -7.75 1 0.1 mass
+12 172.707452999999987 251.48839000000001 0 -7.749999 1 0.1 mass
+13 192.690280000000001 252.317025000000001 0 -7.75 1 0.1 mass
+14 212.67310599999999 253.145659999999992 0 -7.75 1 0.1 mass
+15 232.655933000000005 253.974295000000012 0 -7.75 1 0.1 mass
+16 252.638759999999991 254.802930000000003 0 -7.75 1 0.1 mass
+17 251.810124999999999 274.78575699999999 0 -7.75 1 0.1 mass
+18 250.98148900000001 294.768583999999976 0 -7.75 1 0.1 mass
+19 249.324218999999999 334.734237000000007 0 -7.75 1 0.1 mass
+20 250.152853999999991 314.751410000000021 0 -7.75 1 0.1 mass
+1 1 2 200 1.5 20 spng
+2 2 3 200 1.5 20 spng
+3 3 4 200 1.5 20 spng
+4 4 5 200 1.5 20 spng
+5 5 6 200 1.5 20 spng
+6 6 19 200 1.5 20 spng
+7 19 20 200 1.5 20 spng
+8 20 18 200 1.5 20 spng
+9 18 17 200 1.5 20 spng
+10 17 16 200 1.5 20 spng
+11 16 15 200 1.5 20 spng
+12 15 14 200 1.5 20 spng
+13 14 13 200 1.5 20 spng
+14 13 12 200 1.5 20 spng
+15 12 11 200 1.5 20 spng
+16 11 10 200 1.5 20 spng
+17 10 9 200 1.5 20 spng
+18 9 8 200 1.5 20 spng
+19 8 7 200 1.5 20 spng
+20 7 1 200 1.5 20 spng
+21 1 19 200 1.5 101.98039 spng
+22 19 14 200 1.5 89.4427189999999968 spng
+23 14 8 200 1.5 84.8528139999999951 spng
+24 8 5 200 1.5 89.4427189999999968 spng
+25 5 16 200 1.5 101.98039 spng
+26 16 10 200 1.5 101.98039 spng
+27 10 3 200 1.5 89.4427189999999968 spng
+28 3 18 200 1.5 84.8528139999999951 spng
+29 18 12 200 1.5 89.4427189999999968 spng
+30 12 1 200 1.5 101.98039 spng
+31 2 20 200 1.5 89.4427189999999968 spng
+32 20 13 200 1.5 84.8528139999999951 spng
+33 13 7 200 1.5 89.4427189999999968 spng
+34 7 6 200 1.5 101.98039 spng
+35 6 15 200 1.5 101.98039 spng
+36 15 9 200 1.5 89.4427189999999968 spng
+37 9 4 200 1.5 84.8528139999999951 spng
+38 4 17 200 1.5 89.4427189999999968 spng
+39 17 11 200 1.5 101.98039 spng
+40 11 2 200 1.5 101.98039 spng
+
+nodes> 200 random -100 + 200 random -100 + 2array [ swap set-node-vel ] curry
+each ;
+
+: go ( -- ) [ model ] go* ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces arrays sequences threads math math.vectors
+ ui random
+ springies springies.ui ;
+
+IN: springies.models.urchin
+
+: model ( -- )
+
+{ } clone >nodes
+{ } clone >springs
+0.007 >time-slice
+gravity on
+
+1 507.296953 392.174236 -11.451186 -71.267273 1.0 1.0 mass
+2 514.879820 372.128025 11.950035 -70.858717 1.0 1.0 mass
+3 536.571268 364.423706 18.394466 -41.159445 1.0 1.0 mass
+4 554.886966 369.953895 15.173664 -11.009243 1.0 1.0 mass
+5 572.432935 379.927626 8.228103 -1.120846 1.0 1.0 mass
+6 585.774508 392.380791 5.443281 -8.186599 1.0 1.0 mass
+7 584.650543 411.934530 -15.582843 -24.911756 1.0 1.0 mass
+8 569.409148 424.155713 -24.100159 -42.285960 1.0 1.0 mass
+9 553.751996 434.663690 -26.069217 -41.610454 1.0 1.0 mass
+10 536.684374 444.915694 -30.702349 -45.021926 1.0 1.0 mass
+11 516.677286 435.936238 -33.128410 -60.977340 1.0 1.0 mass
+12 514.170680 414.649472 -24.471518 -64.104425 1.0 1.0 mass
+13 602.101547 478.298945 1.612646 -53.040881 1.0 1.0 mass
+14 637.0 427.598266 0.0 0.0 1.0 1.0 mass
+15 608.000171 350.425575 31.812856 23.456940 1.0 1.0 mass
+16 484.367809 332.414622 42.575378 -91.238351 1.0 1.0 mass
+17 480.857379 475.215663 -24.240991 -53.909049 1.0 1.0 mass
+18 548.580015 492.173168 -34.565312 -52.436468 1.0 1.0 mass
+19 578.155338 487.173526 22.544495 -71.920721 1.0 1.0 mass
+20 630.992588 379.333707 16.662115 37.873709 1.0 1.0 mass
+21 591.256916 324.817423 63.036114 27.988433 1.0 1.0 mass
+22 539.051461 311.597938 159.501014 -27.955219 1.0 1.0 mass
+23 448.396171 396.882674 -15.045910 -138.652372 1.0 1.0 mass
+24 448.194414 419.993896 -27.625008 -84.936708 1.0 1.0 mass
+1 1 2 200.0 3.0 20.0 spng
+2 2 3 200.0 3.0 20.0 spng
+3 3 4 200.0 3.0 20.0 spng
+4 4 5 200.0 3.0 20.0 spng
+5 5 6 200.0 3.0 20.0 spng
+6 6 7 200.0 3.0 20.0 spng
+7 7 8 200.0 3.0 20.0 spng
+8 8 9 200.0 3.0 20.0 spng
+9 9 10 200.0 3.0 20.0 spng
+10 10 11 200.0 3.0 20.0 spng
+11 11 12 200.0 3.0 20.0 spng
+12 1 3 200.0 3.0 40.0 spng
+13 2 4 200.0 3.0 40.0 spng
+14 3 5 200.0 3.0 40.0 spng
+15 4 6 200.0 3.0 40.0 spng
+16 6 8 200.0 3.0 40.0 spng
+17 7 9 200.0 3.0 40.0 spng
+18 8 10 200.0 3.0 40.0 spng
+19 9 11 200.0 3.0 40.0 spng
+20 10 12 200.0 3.0 40.0 spng
+21 12 1 200.0 3.0 21.0 spng
+22 12 2 200.0 3.0 41.0 spng
+23 11 1 200.0 3.0 41.0 spng
+24 6 12 200.0 3.0 72.681733 spng
+25 5 11 200.0 3.0 81.191259 spng
+26 10 4 200.0 3.0 76.026311 spng
+27 3 9 200.0 3.0 72.615425 spng
+28 8 2 200.0 3.0 74.966659 spng
+29 1 7 200.0 3.0 80.280757 spng
+30 17 11 200.0 3.0 55.036352 spng
+31 10 18 200.0 3.0 49.819675 spng
+32 19 9 200.0 3.0 54.918121 spng
+33 8 13 200.0 3.0 62.201286 spng
+34 14 7 200.0 3.0 58.600341 spng
+35 6 20 200.0 3.0 46.400431 spng
+36 15 5 200.0 3.0 44.045431 spng
+37 4 21 200.0 3.0 57.454330 spng
+38 22 3 200.0 3.0 53.823787 spng
+39 2 16 200.0 3.0 51.039201 spng
+40 23 1 200.0 3.0 58.668561 spng
+41 12 24 200.0 3.0 64.404969 spng
+42 24 11 200.0 3.0 71.217975 spng
+43 17 12 200.0 3.0 65.0 spng
+44 11 18 200.0 3.0 60.745370 spng
+45 18 9 200.0 3.0 60.406953 spng
+46 9 13 200.0 3.0 67.779053 spng
+47 13 7 200.0 3.0 66.708320 spng
+48 7 20 200.0 3.0 55.659680 spng
+49 20 5 200.0 3.0 60.0 spng
+50 5 21 200.0 3.0 61.846584 spng
+51 21 3 200.0 3.0 64.031242 spng
+52 3 16 200.0 3.0 63.568860 spng
+53 16 1 200.0 3.0 59.774577 spng
+54 1 24 200.0 3.0 65.802736 spng
+55 17 10 200.0 3.0 64.845971 spng
+56 10 19 200.0 3.0 58.249464 spng
+57 19 8 200.0 3.0 67.268120 spng
+58 8 14 200.0 3.0 67.268120 spng
+59 14 6 200.0 3.0 64.629715 spng
+60 6 15 200.0 3.0 50.089919 spng
+61 15 4 200.0 3.0 56.320511 spng
+62 4 22 200.0 3.0 60.728906 spng
+63 22 2 200.0 3.0 61.032778 spng
+64 2 23 200.0 3.0 66.528190 spng
+65 23 12 200.0 3.0 72.277244 spng
+
+nodes>
+ 75 random -75 + 0 2array [ over node-vel v+ swap set-node-vel ]
+curry each
+
+;
+
+: go ( -- ) [ model ] go* ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+
+USING: kernel combinators sequences arrays math math.vectors
+ generalizations vars accessors math.physics.vel ;
+
+IN: springies
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: scalar-projection ( a b -- n ) [ v. ] [ nip norm ] 2bi / ;
+
+: vector-projection ( a b -- vec )
+ [ nip normalize ] [ scalar-projection ] 2bi v*n ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: nodes
+VAR: springs
+VAR: time-slice
+VAR: world-size
+
+: world-width ( -- width ) world-size> first ;
+
+: world-height ( -- height ) world-size> second ;
+
+VAR: gravity
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! node
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: node < vel mass elas force ;
+
+C: <node> node
+
+: node-vel ( node -- vel ) vel>> ;
+
+: set-node-vel ( vel node -- ) swap >>vel drop ;
+
+: pos-x ( node -- x ) pos>> first ;
+: pos-y ( node -- y ) pos>> second ;
+: vel-x ( node -- y ) vel>> first ;
+: vel-y ( node -- y ) vel>> second ;
+
+: >>pos-x ( node x -- node ) over pos>> set-first ;
+: >>pos-y ( node y -- node ) over pos>> set-second ;
+: >>vel-x ( node x -- node ) over vel>> set-first ;
+: >>vel-y ( node y -- node ) over vel>> set-second ;
+
+: apply-force ( node vec -- ) over force>> v+ >>force drop ;
+
+: reset-force ( node -- node ) 0 0 2array >>force ;
+
+: node-id ( id -- node ) 1- nodes> nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! spring
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: spring rest-length k damp node-a node-b ;
+
+C: <spring> spring
+
+: end-points ( spring -- b-pos a-pos )
+ [ node-b>> pos>> ] [ node-a>> pos>> ] bi ;
+
+: spring-length ( spring -- length ) end-points v- norm ;
+
+: stretch-length ( spring -- length )
+ [ spring-length ] [ rest-length>> ] bi - ;
+
+: dir ( spring -- vec ) end-points v- normalize ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Hooke
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! F = -kx
+!
+! k :: spring constant
+! x :: distance stretched beyond rest length
+!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: hooke-force-mag ( spring -- mag ) [ k>> ] [ stretch-length ] bi * ;
+
+: hooke-force ( spring -- force ) [ dir ] [ hooke-force-mag ] bi v*n ;
+
+: hooke-forces ( spring -- a b ) hooke-force dup vneg ;
+
+: act-on-nodes-hooke ( spring -- )
+ [ node-a>> ] [ node-b>> ] [ ] tri hooke-forces swapd
+ apply-force
+ apply-force ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! damping
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! F = -bv
+!
+! b :: Damping constant
+! v :: Velocity
+!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : damping-force-a ( spring -- vec )
+! [ spring-node-a node-vel ] [ spring-damp ] bi v*n vneg ;
+
+! : damping-force-b ( spring -- vec )
+! [ spring-node-b node-vel ] [ spring-damp ] bi v*n vneg ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: relative-velocity-a ( spring -- vel )
+ [ node-a>> vel>> ] [ node-b>> vel>> ] bi v- ;
+
+: unit-vec-b->a ( spring -- vec )
+ [ node-a>> pos>> ] [ node-b>> pos>> ] bi v- ;
+
+: relative-velocity-along-spring-a ( spring -- vel )
+ [ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ;
+
+: damping-force-a ( spring -- vec )
+ [ relative-velocity-along-spring-a ] [ damp>> ] bi v*n vneg ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: relative-velocity-b ( spring -- vel )
+ [ node-b>> vel>> ] [ node-a>> vel>> ] bi v- ;
+
+: unit-vec-a->b ( spring -- vec )
+ [ node-b>> pos>> ] [ node-a>> pos>> ] bi v- ;
+
+: relative-velocity-along-spring-b ( spring -- vel )
+ [ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ;
+
+: damping-force-b ( spring -- vec )
+ [ relative-velocity-along-spring-b ] [ damp>> ] bi v*n vneg ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: act-on-nodes-damping ( spring -- )
+ dup
+ [ node-a>> ] [ damping-force-a ] bi apply-force
+ [ node-b>> ] [ damping-force-b ] bi apply-force ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: below? ( node -- ? ) pos-y 0 < ;
+
+: above? ( node -- ? ) pos-y world-height >= ;
+
+: beyond-left? ( node -- ? ) pos-x 0 < ;
+
+: beyond-right? ( node -- ? ) pos-x world-width >= ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bounce-top ( node -- )
+ world-height 1- >>pos-y
+ dup [ vel-y ] [ elas>> ] bi * neg >>vel-y
+ drop ;
+
+: bounce-bottom ( node -- )
+ 0 >>pos-y
+ dup [ vel-y ] [ elas>> ] bi * neg >>vel-y
+ drop ;
+
+: bounce-left ( node -- )
+ 0 >>pos-x
+ dup [ vel-x ] [ elas>> ] bi * neg >>vel-x
+ drop ;
+
+: bounce-right ( node -- )
+ world-width 1- >>pos-x
+ dup [ vel-x ] [ elas>> ] bi * neg >>vel-x
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: handle-bounce ( node -- )
+ { { [ dup above? ] [ bounce-top ] }
+ { [ dup below? ] [ bounce-bottom ] }
+ { [ dup beyond-left? ] [ bounce-left ] }
+ { [ dup beyond-right? ] [ bounce-right ] }
+ { [ t ] [ drop ] } }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: act-on-nodes ( spring -- )
+ dup
+ act-on-nodes-hooke
+ act-on-nodes-damping ;
+
+! : act-on-nodes ( spring -- ) act-on-nodes-hooke ;
+
+: loop-over-springs ( -- ) springs> [ act-on-nodes ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: apply-gravity ( node -- ) { 0 -9.8 } apply-force ;
+
+: do-gravity ( -- ) gravity> [ nodes> [ apply-gravity ] each ] when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! F = ma
+
+: calc-acceleration ( node -- vec ) [ force>> ] [ mass>> ] bi v/n ;
+
+: new-vel ( node -- vel )
+ [ vel>> ] [ calc-acceleration time-slice> v*n ] bi v+ ;
+
+: new-pos ( node -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ;
+
+: iterate-node ( node -- )
+ dup new-pos >>pos
+ dup new-vel >>vel
+ reset-force
+ handle-bounce ;
+
+: iterate-nodes ( -- ) nodes> [ iterate-node ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: iterate-system ( -- ) do-gravity loop-over-springs iterate-nodes ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Reading xspringies data files
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mass ( id x y x-vel y-vel mass elas -- )
+ node new
+ swap >>elas
+ swap >>mass
+ -rot 2array >>vel
+ -rot 2array >>pos
+ 0 0 2array >>force
+ nodes> swap suffix >nodes
+ drop ;
+
+: spng ( id id-a id-b k damp rest-length -- )
+ spring new
+ swap >>rest-length
+ swap >>damp
+ swap >>k
+ swap node-id >>node-b
+ swap node-id >>node-a
+ springs> swap suffix >springs
+ drop ;
\ No newline at end of file
--- /dev/null
+Mass and spring simulation (inspired by xspringies)
--- /dev/null
+simulation
+physics
+demos
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces threads sequences math math.vectors
+ opengl.gl opengl colors ui ui.gadgets ui.gadgets.slate
+ fry rewrite-closures vars springies accessors math.geometry.rect ;
+
+IN: springies.ui
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: draw-node ( node -- ) pos>> { -5 -5 } v+ [ { 10 10 } gl-rect ] with-translation ;
+
+: draw-spring ( spring -- )
+ [ node-a>> pos>> ] [ node-b>> pos>> ] bi gl-line ;
+
+: draw-nodes ( -- ) nodes> [ draw-node ] each ;
+
+: draw-springs ( -- ) springs> [ draw-spring ] each ;
+
+: set-projection ( -- )
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ 0 world-width 1- 0 world-height 1- -1 1 glOrtho
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity ;
+
+! : display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
+
+: display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: slate
+
+VAR: loop
+
+: update-world-size ( -- ) slate> rect-dim >world-size ;
+
+: refresh-slate ( -- ) slate> relayout-1 ;
+
+DEFER: maybe-loop
+
+: run ( -- )
+ update-world-size
+ iterate-system
+ refresh-slate
+ yield
+ maybe-loop ;
+
+: maybe-loop ( -- ) loop> [ run ] when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: springies-window* ( -- )
+
+ C[ display ] <slate>
+ { 800 600 } >>pdim
+ C[ { 500 500 } >world-size loop on [ run ] in-thread ] >>graft
+ C[ loop off ] >>ungraft
+ [ >slate ] [ "Springies" open-window ] bi ;
+
+: springies-window ( -- ) [ [ springies-window* ] with-scope ] with-ui ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: go* ( quot -- ) '[ [ springies-window* 1000 sleep @ ] with-scope ] with-ui ;
--- /dev/null
+William Schlieper
\ No newline at end of file
--- /dev/null
+Tabbed windows
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: accessors kernel fry math math.vectors sequences arrays vectors assocs\r
+ hashtables models models.range models.product combinators\r
+ ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs\r
+ ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;\r
+\r
+IN: ui.gadgets.tabs\r
+\r
+TUPLE: tabbed < frame names toggler content ;\r
+\r
+DEFER: (del-page)\r
+\r
+:: add-toggle ( n name model toggler -- )\r
+ <frame>\r
+ n name toggler parent>> '[ drop _ _ _ (del-page) ] "X" swap <bevel-button>\r
+ @right grid-add\r
+ n model name <toggle-button> @center grid-add\r
+ toggler swap add-gadget drop ;\r
+\r
+: redo-toggler ( tabbed -- )\r
+ [ names>> ] [ model>> ] [ toggler>> ] tri\r
+ [ clear-gadget ] keep\r
+ [ [ length ] keep ] 2dip\r
+ '[ _ _ add-toggle ] 2each ;\r
+\r
+: refresh-book ( tabbed -- )\r
+ model>> [ ] change-model ;\r
+\r
+: (del-page) ( n name tabbed -- )\r
+ { [ [ remove ] change-names redo-toggler ]\r
+ [ dupd [ names>> length ] [ model>> ] bi\r
+ [ [ = ] keep swap [ 1- ] when\r
+ [ < ] keep swap [ 1- ] when ] change-model ]\r
+ [ content>> nth-gadget unparent ]\r
+ [ refresh-book ]\r
+ } cleave ;\r
+\r
+: add-page ( page name tabbed -- )\r
+ [ names>> push ] 2keep\r
+ [ [ names>> length 1 - swap ]\r
+ [ model>> ]\r
+ [ toggler>> ] tri add-toggle ]\r
+ [ content>> swap add-gadget drop ]\r
+ [ refresh-book ] tri ;\r
+\r
+: del-page ( name tabbed -- )\r
+ [ names>> index ] 2keep (del-page) ;\r
+\r
+: new-tabbed ( assoc class -- tabbed )\r
+ new-frame\r
+ 0 <model> >>model\r
+ <pile> 1 >>fill >>toggler\r
+ dup toggler>> @left grid-add\r
+ swap\r
+ [ keys >vector >>names ]\r
+ [ values over model>> <book> >>content dup content>> @center grid-add ]\r
+ bi\r
+ dup redo-toggler ;\r
+ \r
+: <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;\r
--- /dev/null
+
+USING: kernel accessors locals namespaces sequences threads
+ math math.order math.vectors
+ calendar
+ colors opengl ui ui.gadgets ui.gestures ui.render
+ circular
+ processing.shapes ;
+
+IN: trails
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Example 33-15 from the Processing book
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Return the mouse location relative to the current gadget
+
+: mouse ( -- point ) hand-loc get hand-gadget get screen-loc v- ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: point-list ( n -- seq ) [ drop { 0 0 } ] map <circular> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: percent->radius ( percent -- radius ) neg 1 + 25 * 5 max ;
+
+: dot ( pos percent -- ) percent->radius circle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <trails-gadget> < gadget paused points ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-system ( GADGET -- )
+
+ ! Add a valid point if the mouse is in the gadget
+ ! Otherwise, add an "invisible" point
+
+ hand-gadget get GADGET =
+ [ mouse GADGET points>> push-circular ]
+ [ { -10 -10 } GADGET points>> push-circular ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-trails-thread ( GADGET -- )
+ GADGET f >>paused drop
+ [
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
+ if
+ ]
+ loop
+ ]
+ in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: <trails-gadget> pref-dim* ( <trails-gadget> -- dim ) drop { 500 500 } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: each-percent ( seq quot -- )
+ [
+ dup length
+ dup [ / ] curry
+ [ 1+ ] prepose
+ ] dip compose
+ 2each ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <trails-gadget> draw-gadget* ( GADGET -- )
+ origin get
+ [
+ T{ rgba f 1 1 1 0.4 } \ fill-color set ! White, with some transparency
+ T{ rgba f 0 0 0 0 } \ stroke-color set ! no stroke
+
+ black gl-clear
+
+ GADGET points>> [ dot ] each-percent
+ ]
+ with-translation ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: trails-gadget ( -- <trails-gadget> )
+
+ <trails-gadget> new-gadget
+
+ 300 point-list >>points
+
+ t >>clipped?
+
+ dup start-trails-thread ;
+
+: trails-window ( -- ) [ trails-gadget "Trails" open-window ] with-ui ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: trails-window
\ No newline at end of file
projects / factor.git / commitdiff