| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | USING: kernel namespaces math quotations arrays hashtables sequences threads | 
					
						
							|  |  |  |        opengl | 
					
						
							|  |  |  |        opengl.gl | 
					
						
							|  |  |  |        colors | 
					
						
							|  |  |  |        ui | 
					
						
							|  |  |  |        ui.gestures | 
					
						
							|  |  |  |        ui.gadgets | 
					
						
							|  |  |  |        ui.gadgets.slate | 
					
						
							|  |  |  |        ui.gadgets.labels | 
					
						
							|  |  |  |        ui.gadgets.buttons | 
					
						
							|  |  |  |        ui.gadgets.frames | 
					
						
							|  |  |  |        ui.gadgets.packs | 
					
						
							|  |  |  |        ui.gadgets.grids | 
					
						
							|  |  |  |        ui.gadgets.theme | 
					
						
							| 
									
										
										
										
											2008-07-17 22:14:12 -04:00
										 |  |  |        ui.gadgets.handler | 
					
						
							| 
									
										
										
										
											2008-07-12 17:46:50 -04:00
										 |  |  |        accessors | 
					
						
							| 
									
										
										
										
											2008-12-18 01:16:43 -05:00
										 |  |  |        vars fry | 
					
						
							| 
									
										
										
										
											2008-07-12 17:46:50 -04:00
										 |  |  |        rewrite-closures automata math.geometry.rect newfx ;
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | IN: automata.ui | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-12-18 01:16:43 -05:00
										 |  |  | : draw-line ( y line -- ) 0 swap [ [ 2dup ] dip draw-point 1+ ] each 2drop ;
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-12-18 01:16:43 -05:00
										 |  |  | : (draw-bitmap) ( bitmap -- ) 0 swap [ [ dup ] dip draw-line 1+ ] each drop ;
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | : draw-bitmap ( bitmap -- ) GL_POINTS glBegin (draw-bitmap) glEnd ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-11-11 04:10:41 -05:00
										 |  |  | : display ( -- ) black gl-color bitmap> draw-bitmap ;
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | VAR: slate | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | ! Call a 'model' quotation with the current 'view'. | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : with-view ( quot -- )
 | 
					
						
							| 
									
										
										
										
											2008-11-17 00:31:36 -05:00
										 |  |  |   slate> rect-dim first >width | 
					
						
							|  |  |  |   slate> rect-dim second >height | 
					
						
							|  |  |  |   call
 | 
					
						
							|  |  |  |   slate> relayout-1 ;
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | ! Create a quotation that is appropriate for buttons and gesture handler. | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-12-18 01:16:43 -05:00
										 |  |  | : view-action ( quot -- quot ) '[ drop _ with-view ] closed-quot ;
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-12-18 01:16:43 -05:00
										 |  |  | : view-button ( label quot -- button ) [ <label> ] dip view-action <bevel-button> ;
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | ! Helper word to make things less verbose | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : random-rule ( -- ) set-interesting start-center ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | DEFER: automata-window | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-07-12 17:46:50 -04:00
										 |  |  | : automata-window* ( -- )
 | 
					
						
							|  |  |  |   init-rule | 
					
						
							|  |  |  |   set-interesting | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  |   <frame> | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  |     <shelf> | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  |       "1 - Center"      [ start-center    ] view-button add-gadget | 
					
						
							|  |  |  |       "2 - Random"      [ start-random    ] view-button add-gadget | 
					
						
							|  |  |  |       "3 - Continue"    [ run-rule        ] view-button add-gadget | 
					
						
							|  |  |  |       "5 - Random Rule" [ random-rule     ] view-button add-gadget | 
					
						
							|  |  |  |       "n - New"         [ automata-window ] view-button add-gadget | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-07-25 13:34:41 -04:00
										 |  |  |     @top grid-add | 
					
						
							| 
									
										
										
										
											2008-07-12 17:46:50 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  |     C[ display ] <slate> | 
					
						
							| 
									
										
										
										
											2008-07-17 19:30:19 -04:00
										 |  |  |       { 400 400 } >>pdim | 
					
						
							| 
									
										
										
										
											2008-07-12 17:46:50 -04:00
										 |  |  |     dup >slate | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-07-25 13:34:41 -04:00
										 |  |  |     @center grid-add | 
					
						
							| 
									
										
										
										
											2008-07-12 17:46:50 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-07-17 22:14:12 -04:00
										 |  |  |   <handler> | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-07-12 17:46:50 -04:00
										 |  |  |   H{ } | 
					
						
							|  |  |  |     T{ key-down f f "1" } [ start-center    ] view-action is | 
					
						
							|  |  |  |     T{ key-down f f "2" } [ start-random    ] view-action is | 
					
						
							|  |  |  |     T{ key-down f f "3" } [ run-rule        ] view-action is | 
					
						
							|  |  |  |     T{ key-down f f "5" } [ random-rule     ] view-action is | 
					
						
							|  |  |  |     T{ key-down f f "n" } [ automata-window ] view-action is | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-07-17 22:14:12 -04:00
										 |  |  |   >>table | 
					
						
							| 
									
										
										
										
											2008-07-12 17:46:50 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  |   "Automata" open-window ;
 | 
					
						
							| 
									
										
										
										
											2007-09-20 18:09:08 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : automata-window ( -- ) [ [ automata-window* ] with-scope ] with-ui ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-01-16 16:25:29 -05:00
										 |  |  | MAIN: automata-window |