+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel math math.parser random arrays hashtables assocs sequences
- grouping vars ;
-
-IN: automata
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! set-rule
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: rule VAR: rule-number
-
-: init-rule ( -- ) 8 <hashtable> >rule ;
-
-: rule-keys ( -- array )
- { { 1 1 1 }
- { 1 1 0 }
- { 1 0 1 }
- { 1 0 0 }
- { 0 1 1 }
- { 0 1 0 }
- { 0 0 1 }
- { 0 0 0 } } ;
-
-: rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-head string>digits ;
-
-: set-rule ( n -- )
- dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! step-capped-line
-! step-wrapped-line
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pattern>state ( {_a_b_c_} -- state ) rule> at ;
-
-: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
-
-: wrap-line ( a-line-z -- za-line-za )
- dup peek 1array swap dup first 1array append append ;
-
-: step-line ( line -- new-line ) 3 <clumps> [ pattern>state ] map ;
-
-: step-capped-line ( line -- new-line ) cap-line step-line ;
-: step-wrapped-line ( line -- new-line ) wrap-line step-line ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VARS: width height ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: random-line ( -- line ) width> [ drop 2 random ] map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: center-i ( -- i ) width> 2 / >fixnum ;
-
-: center-line ( -- line ) center-i width> [ = 1 0 ? ] with map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: interesting ( -- seq )
- { 18 22 26 30 41 45 54 60 73 75 82 86 89 90 97 101 102 105 106 107 109
- 110 120 121 122 124 126 129 137 146 147 149 150 151 153 154 161 165 } ;
-
-: mild ( -- seq ) { 6 9 11 57 62 74 118 } ;
-
-: set-interesting ( -- ) interesting random set-rule ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: bitmap
-
-VAR: last-line
-
-: run-rule ( -- )
- last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start-random ( -- ) random-line >last-line run-rule ;
-
-: start-center ( -- ) center-line >last-line run-rule ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! VAR: loop-flag
-
-! DEFER: loop
-
-! : (loop) ( -- ) run-rule 3000 sleep loop ;
-
-! : loop ( -- ) loop-flag> [ (loop) ] [ ] if ;
-
-! : start-loop ( -- ) t >loop-flag [ loop ] in-thread ;
-
-! : stop-loop ( -- ) f >loop-flag ;
+++ /dev/null
-Cellular Automata Explorer (one dimensional, two state)
+++ /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 "Cellular Automata" }
-}
+++ /dev/null
-
-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
- ui.gadgets.handler
- accessors
- vars fry
- rewrite-closures automata math.geometry.rect newfx ;
-
-IN: automata.ui
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ;
-
-: draw-line ( y line -- ) 0 swap [ [ 2dup ] dip draw-point 1+ ] each 2drop ;
-
-: (draw-bitmap) ( bitmap -- ) 0 swap [ [ dup ] dip draw-line 1+ ] each drop ;
-
-: draw-bitmap ( bitmap -- ) GL_POINTS glBegin (draw-bitmap) glEnd ;
-
-: display ( -- ) black gl-color bitmap> draw-bitmap ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: slate
-
-! Call a 'model' quotation with the current 'view'.
-
-: with-view ( quot -- )
- slate> rect-dim first >width
- slate> rect-dim second >height
- call
- slate> relayout-1 ;
-
-! Create a quotation that is appropriate for buttons and gesture handler.
-
-: view-action ( quot -- quot ) '[ drop _ with-view ] closed-quot ;
-
-: view-button ( label quot -- button ) [ <label> ] dip view-action <bevel-button> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Helper word to make things less verbose
-
-: random-rule ( -- ) set-interesting start-center ;
-
-DEFER: automata-window
-
-: 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
-
- @top grid-add
-
- C[ display ] <slate>
- { 400 400 } >>pdim
- dup >slate
-
- @center grid-add
-
- <handler>
-
- 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
-
- >>table
-
- "Automata" open-window ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: automata-window ( -- ) [ [ automata-window* ] with-scope ] with-ui ;
-
-MAIN: automata-window
+++ /dev/null
-
-USING: arrays assocs compiler.units
- grouping help help.markup help.topics kernel lexer multiline
- namespaces parser sequences splitting words
- easy-help.expand-markup ;
-
-IN: easy-help
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: parse-text-block ( -- array )
-
- ".." parse-multiline-string
- string-lines
- 1 tail
- [ dup " " head? [ 4 tail ] [ ] if ] map
- [ expand-markup ] map
- concat
- [ dup "" = [ drop { $nl } ] [ ] if ] map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: Text: parse-text-block parsed ; parsing
-
-: Block: scan-word 1array parse-text-block append parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: Notes: { $notes } parse-text-block append parsed ; parsing
-: Description: { $description } parse-text-block append parsed ; parsing
-: Contract: { $contract } parse-text-block append parsed ; parsing
-: Checked-Example: { $example } parse-text-block append parsed ; parsing
-
-: Class-Description:
- { $class-description } parse-text-block append parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: Code:
-
- { $code }
- parse-text-block [ dup array? [ drop "" ] [ ] if ] map
- append
- parsed
-
- ; parsing
-
-: Example:
- { $heading "Example" }
- { $code }
- parse-text-block
- [ dup array? [ drop "" ] [ ] if ] map ! Each item in $code must be a string
- append
- 2array parsed ; parsing
-
-: Introduction:
-
- { $heading "Introduction" }
- parse-text-block
- 2array parsed ; parsing
-
-: Summary:
-
- { $heading "Summary" }
- parse-text-block
- 2array parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: Values:
-
- ".." parse-multiline-string
- string-lines
- 1 tail
- [ dup " " head? [ 4 tail ] [ ] if ] map
- [ " " split1 [ " " first = ] trim-head 2array ] map
- \ $values prefix
- parsed
-
- ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: Word:
-
- scan current-vocab create dup old-definitions get
- [ delete-at ] with each dup set-word
-
- bootstrap-word dup set-word
- dup >link save-location
- \ ; parse-until >array swap set-word-help ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: Heading: { $heading } ".." parse-multiline-string suffix parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: List:
-
- { $list }
-
- ".." parse-multiline-string
- string-lines
- 1 tail
- [ dup " " head? [ 4 tail ] [ ] if ] map
- [ expand-markup ] map
-
- append parsed
-
- ; parsing
+++ /dev/null
-
-USING: accessors arrays kernel lexer locals math namespaces parser
- sequences splitting ;
-
-IN: easy-help.expand-markup
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: scan-one-array ( string -- array rest )
- string-lines
- lexer-factory get call
- [
- [
- \ } parse-until >array
- lexer get line-text>>
- lexer get column>> tail
- ]
- with-lexer
- ]
- with-scope ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: contains-markup? ( string -- ? ) "{ $" swap subseq? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: expand-markup ( LINE -- lines )
-
- LINE contains-markup?
- [
-
- [let | N [ "{ $" LINE start ] |
-
- LINE N head
-
- LINE N 2 + tail scan-one-array dup " " head? [ 1 tail ] [ ] if
-
- [ 2array ] dip
-
- expand-markup
-
- append ]
-
- ]
- [ LINE 1array ]
- if ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-IN: ori.tests
-USING: ori tools.test ;
-
-\ pitch-up must-infer
-\ pitch-down must-infer
-\ turn-left must-infer
-\ turn-right must-infer
-\ roll-left must-infer
-\ roll-right must-infer
+++ /dev/null
-
-USING: kernel namespaces make accessors
- math math.constants math.functions math.matrices math.vectors
- sequences splitting grouping self math.trig ;
-
-IN: ori
-
-TUPLE: ori val ;
-
-C: <ori> ori
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ori> ( -- val ) self> val>> ;
-
-: >ori ( val -- ) self> (>>val) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-matrix ( quot width -- matrix ) [ { } make ] dip group ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! These rotation matrices are from
-! `Computer Graphics: Principles and Practice'
-
-: Rz ( angle -- Rx ) deg>rad
-[ dup cos , dup sin neg , 0 ,
- dup sin , dup cos , 0 ,
- 0 , 0 , 1 , ] 3 make-matrix nip ;
-
-: Ry ( angle -- Ry ) deg>rad
-[ dup cos , 0 , dup sin ,
- 0 , 1 , 0 ,
- dup sin neg , 0 , dup cos , ] 3 make-matrix nip ;
-
-: Rx ( angle -- Rz ) deg>rad
-[ 1 , 0 , 0 ,
- 0 , dup cos , dup sin neg ,
- 0 , dup sin , dup cos , ] 3 make-matrix nip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: apply-rotation ( rotation -- ) ori> swap m. >ori ;
-
-: rotate-x ( angle -- ) Rx apply-rotation ;
-: rotate-y ( angle -- ) Ry apply-rotation ;
-: rotate-z ( angle -- ) Rz apply-rotation ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pitch-up ( angle -- ) neg rotate-x ;
-: pitch-down ( angle -- ) rotate-x ;
-
-: turn-left ( angle -- ) rotate-y ;
-: turn-right ( angle -- ) neg rotate-y ;
-
-: roll-left ( angle -- ) neg rotate-z ;
-: roll-right ( angle -- ) rotate-z ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! roll-until-horizontal
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: V ( -- V ) { 0 1 0 } ;
-
-: X ( -- 3array ) ori> [ first ] map ;
-: Y ( -- 3array ) ori> [ second ] map ;
-: Z ( -- 3array ) ori> [ third ] map ;
-
-: set-X ( seq -- ) ori> [ set-first ] 2each ;
-: set-Y ( seq -- ) ori> [ set-second ] 2each ;
-: set-Z ( seq -- ) ori> [ set-third ] 2each ;
-
-: roll-until-horizontal ( -- )
-V Z cross normalize set-X
-Z X cross normalize set-Y ;
-
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel math math.functions math.vectors sequences self
-accessors ;
-
-IN: pos
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: pos val ;
-
-C: <pos> pos
-
-: pos> ( -- val ) self> val>> ;
-
-: >pos ( val -- ) self> (>>val) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: distance ( pos pos -- n ) val>> swap val>> v- [ sq ] map sum sqrt ;
-
-: move-by ( point -- ) pos> v+ >pos ;
-
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays quotations sequences assocs combinators
- mirrors math math.vectors random macros fry ;
-
-IN: random-weighted
-
-: probabilities ( weights -- probabilities ) dup sum v/n ;
-
-: layers ( probabilities -- layers )
-dup length 1+ [ head ] with map rest [ sum ] map ;
-
-: random-weighted ( weights -- elt )
-probabilities layers [ 1000 * ] map 1000 random [ > ] curry find drop ;
-
-: random-weighted* ( seq -- elt )
-dup [ second ] map swap [ first ] map random-weighted swap nth ;
-
-MACRO: call-random-weighted ( exp -- )
- [ keys ] [ values <enum> >alist ] bi
- '[ _ random-weighted _ case ] ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel parser math quotations namespaces sequences macros fry ;
-
-IN: rewrite-closures
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: [set-parameters] ( seq -- quot ) reverse [ [ set ] curry ] map concat ;
-
-MACRO: set-parameters ( seq -- quot ) [set-parameters] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: parametric-quot ( parameters quot -- quot ) '[ _ set-parameters _ call ] ;
-
-: scoped-quot ( quot -- quot ) '[ _ with-scope ] ;
-
-: closed-quot ( quot -- quot )
- namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: lambda ( parameters quot -- quot ) parametric-quot scoped-quot closed-quot ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: C[ \ ] [ >quotation ] parse-literal \ closed-quot parsed ; parsing
\ No newline at end of file
+++ /dev/null
-Closures implemented via quotation rewriting
+++ /dev/null
-extensions
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces vars ;
-
-IN: self
-
-VAR: self
-
-: with-self ( quot obj -- ) [ >self call ] with-scope ;
-
-: save-self ( quot -- ) self> [ self> clone >self call ] dip >self ;
+++ /dev/null
-
-USING: kernel words lexer parser sequences accessors self ;
-
-IN: self.slots
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: define-self-slot-reader ( slot -- )
- [ "->" append current-vocab create dup set-word ]
- [ ">>" append search [ self> ] swap suffix ] bi
- (( -- value )) define-declared ;
-
-: define-self-slot-writer ( slot -- )
- [ "->" prepend current-vocab create dup set-word ]
- [ ">>" prepend search [ self> swap ] swap suffix [ drop ] append ] bi
- (( value -- )) define-declared ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: define-self-slot-accessors ( class -- )
- "slots" word-prop
- [ name>> ] map
- [ [ define-self-slot-reader ] [ define-self-slot-writer ] bi ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: SELF-SLOTS: scan-word define-self-slot-accessors ; parsing
\ No newline at end of file
+++ /dev/null
-
-USING: kernel lexer parser words quotations compiler.units ;
-
-IN: sto
-
-! Use 'sto' to bind a value on the stack to a word.
-!
-! Example:
-!
-! 10 sto A
-
-: sto
- \ 1quotation parsed
- scan
- current-vocab create
- dup set-word
- literalize parsed
- \ swap parsed
- [ define ] parsed
- \ with-compilation-unit parsed ; parsing
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: kernel tools.test sequences vectors assocs.lib ;
-IN: assocs.lib.tests
-
-{ 1 1 } [ [ ?push ] histogram ] must-infer-as
-
-! substitute
-[ { 2 } ] [ { 1 } H{ { 1 2 } } [ ?at drop ] curry map ] unit-test
-[ { 3 } ] [ { 3 } H{ { 1 2 } } [ ?at drop ] curry map ] unit-test
-
-[ 2 ] [ 1 H{ { 1 2 } } [ ] [ ] if-at ] unit-test
-[ 3 ] [ 3 H{ { 1 2 } } [ ] [ ] if-at ] unit-test
-
-[ "hi" ] [ 1 H{ { 1 2 } } [ drop "hi" ] when-at ] unit-test
-[ 3 ] [ 3 H{ { 1 2 } } [ drop "hi" ] when-at ] unit-test
-[ 2 ] [ 1 H{ { 1 2 } } [ drop "hi" ] unless-at ] unit-test
-[ "hi" ] [ 3 H{ { 1 2 } } [ drop "hi" ] unless-at ] unit-test
-
+++ /dev/null
-USING: arrays assocs kernel vectors sequences namespaces
- random math.parser math fry ;
-
-IN: assocs.lib
-
-: set-assoc-stack ( value key seq -- )
- dupd [ key? ] with find-last nip set-at ;
-
-: at-default ( key assoc -- value/key )
- dupd at [ nip ] when* ;
-
-: replace-at ( assoc value key -- assoc )
- [ dupd 1vector ] dip rot set-at ;
-
-: peek-at* ( assoc key -- obj ? )
- swap at* dup [ [ peek ] dip ] when ;
-
-: peek-at ( assoc key -- obj )
- peek-at* drop ;
-
-: >multi-assoc ( assoc -- new-assoc )
- [ 1vector ] assoc-map ;
-
-: multi-assoc-each ( assoc quot -- )
- [ with each ] curry assoc-each ; inline
-
-: insert ( value variable -- ) namespace push-at ;
-
-: generate-key ( assoc -- str )
- [ 32 random-bits >hex ] dip
- 2dup key? [ nip generate-key ] [ drop ] if ;
-
-: set-at-unique ( value assoc -- key )
- dup generate-key [ swap set-at ] keep ;
-
-: histogram ( assoc quot -- assoc' )
- H{ } clone [
- swap [ change-at ] 2curry assoc-each
- ] keep ; inline
-
-: ?at ( obj assoc -- value/obj ? )
- dupd at* [ [ nip ] [ drop ] if ] keep ;
-
-: if-at ( obj assoc quot1 quot2 -- )
- [ ?at ] 2dip if ; inline
-
-: when-at ( obj assoc quot -- ) [ ] if-at ; inline
-
-: unless-at ( obj assoc quot -- ) [ ] swap if-at ; inline
+++ /dev/null
-Non-core assoc words
+++ /dev/null
-collections
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel math math.parser random arrays hashtables assocs sequences
+ grouping vars ;
+
+IN: automata
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! set-rule
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: rule VAR: rule-number
+
+: init-rule ( -- ) 8 <hashtable> >rule ;
+
+: rule-keys ( -- array )
+ { { 1 1 1 }
+ { 1 1 0 }
+ { 1 0 1 }
+ { 1 0 0 }
+ { 0 1 1 }
+ { 0 1 0 }
+ { 0 0 1 }
+ { 0 0 0 } } ;
+
+: rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-head string>digits ;
+
+: set-rule ( n -- )
+ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! step-capped-line
+! step-wrapped-line
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pattern>state ( {_a_b_c_} -- state ) rule> at ;
+
+: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
+
+: wrap-line ( a-line-z -- za-line-za )
+ dup peek 1array swap dup first 1array append append ;
+
+: step-line ( line -- new-line ) 3 <clumps> [ pattern>state ] map ;
+
+: step-capped-line ( line -- new-line ) cap-line step-line ;
+: step-wrapped-line ( line -- new-line ) wrap-line step-line ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VARS: width height ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: random-line ( -- line ) width> [ drop 2 random ] map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: center-i ( -- i ) width> 2 / >fixnum ;
+
+: center-line ( -- line ) center-i width> [ = 1 0 ? ] with map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: interesting ( -- seq )
+ { 18 22 26 30 41 45 54 60 73 75 82 86 89 90 97 101 102 105 106 107 109
+ 110 120 121 122 124 126 129 137 146 147 149 150 151 153 154 161 165 } ;
+
+: mild ( -- seq ) { 6 9 11 57 62 74 118 } ;
+
+: set-interesting ( -- ) interesting random set-rule ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: bitmap
+
+VAR: last-line
+
+: run-rule ( -- )
+ last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: start-random ( -- ) random-line >last-line run-rule ;
+
+: start-center ( -- ) center-line >last-line run-rule ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! VAR: loop-flag
+
+! DEFER: loop
+
+! : (loop) ( -- ) run-rule 3000 sleep loop ;
+
+! : loop ( -- ) loop-flag> [ (loop) ] [ ] if ;
+
+! : start-loop ( -- ) t >loop-flag [ loop ] in-thread ;
+
+! : stop-loop ( -- ) f >loop-flag ;
--- /dev/null
+Cellular Automata Explorer (one dimensional, two state)
--- /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 "Cellular Automata" }
+}
--- /dev/null
+
+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
+ ui.gadgets.handler
+ accessors
+ vars fry
+ rewrite-closures automata math.geometry.rect newfx ;
+
+IN: automata.ui
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ;
+
+: draw-line ( y line -- ) 0 swap [ [ 2dup ] dip draw-point 1+ ] each 2drop ;
+
+: (draw-bitmap) ( bitmap -- ) 0 swap [ [ dup ] dip draw-line 1+ ] each drop ;
+
+: draw-bitmap ( bitmap -- ) GL_POINTS glBegin (draw-bitmap) glEnd ;
+
+: display ( -- ) black gl-color bitmap> draw-bitmap ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: slate
+
+! Call a 'model' quotation with the current 'view'.
+
+: with-view ( quot -- )
+ slate> rect-dim first >width
+ slate> rect-dim second >height
+ call
+ slate> relayout-1 ;
+
+! Create a quotation that is appropriate for buttons and gesture handler.
+
+: view-action ( quot -- quot ) '[ drop _ with-view ] closed-quot ;
+
+: view-button ( label quot -- button ) [ <label> ] dip view-action <bevel-button> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Helper word to make things less verbose
+
+: random-rule ( -- ) set-interesting start-center ;
+
+DEFER: automata-window
+
+: 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
+
+ @top grid-add
+
+ C[ display ] <slate>
+ { 400 400 } >>pdim
+ dup >slate
+
+ @center grid-add
+
+ <handler>
+
+ 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
+
+ >>table
+
+ "Automata" open-window ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: automata-window ( -- ) [ [ automata-window* ] with-scope ] with-ui ;
+
+MAIN: automata-window
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel tools.test bake ;
-
-IN: bake.tests
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: unit-test* ( input output -- ) swap unit-test ;
-
-: must-be-t ( in -- ) [ t ] swap unit-test ;
-: must-be-f ( in -- ) [ f ] swap unit-test ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[ 10 20 30 `{ , , , } ] [ { 10 20 30 } ] unit-test*
-
-[ 10 20 30 `{ , { , } , } ] [ { 10 { 20 } 30 } ] unit-test*
-
-[ 10 { 20 21 22 } 30 `{ , , , } ] [ { 10 { 20 21 22 } 30 } ] unit-test*
-
-[ 10 { 20 21 22 } 30 `{ , @ , } ] [ { 10 20 21 22 30 } ] unit-test*
-
-[ { 1 2 3 } `{ @ } ] [ { 1 2 3 } ] unit-test*
-
-[ { 1 2 3 } { 4 5 6 } { 7 8 9 } `{ @ @ @ } ]
-[ { 1 2 3 4 5 6 7 8 9 } ]
-unit-test*
-
+++ /dev/null
-
-USING: kernel parser namespaces sequences quotations arrays vectors splitting
- strings words math generalizations
- macros combinators.conditional newfx ;
-
-IN: bake
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: ,
-SYMBOL: @
-
-: comma? ( obj -- ? ) , = ;
-: atsym? ( obj -- ? ) @ = ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: [bake]
-
-: broil-element ( obj -- quot )
- {
- { [ comma? ] [ drop [ >r ] ] }
- { [ f = ] [ [ >r ] prefix-on ] }
- { [ integer? ] [ [ >r ] prefix-on ] }
- { [ string? ] [ [ >r ] prefix-on ] }
- { [ sequence? ] [ [bake] [ >r ] append ] }
- { [ word? ] [ literalize [ >r ] prefix-on ] }
- { [ drop t ] [ [ >r ] prefix-on ] }
- }
- 1cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: constructor ( seq -- quot )
- {
- { [ array? ] [ length [ narray ] prefix-on ] }
-! { [ quotation? ] [ length [ ncurry ] prefix-on [ ] prefix ] }
- { [ quotation? ] [ length [ narray >quotation ] prefix-on ] }
- { [ vector? ] [ length [ narray >vector ] prefix-on ] }
- }
- 1cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: [broil] ( seq -- quot )
- [ reverse [ broil-element ] map concat ]
- [ length [ drop [ r> ] ] map concat ]
- [ constructor ]
- tri append append
- >quotation ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: saved-sequence
-
-: [connector] ( -- quot )
- saved-sequence get quotation? [ [ compose ] ] [ [ append ] ] if ;
-
-: [starter] ( -- quot )
- saved-sequence get
- {
- { [ quotation? ] [ drop [ [ ] ] ] }
- { [ array? ] [ drop [ { } ] ] }
- { [ vector? ] [ drop [ V{ } ] ] }
- }
- 1cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: [simmer] ( seq -- quot )
-
- dup saved-sequence set
-
- { @ } split reverse
- [ [ [bake] [connector] append [ >r ] append ] map concat ]
- [ length [ drop [ r> ] [connector] append ] map concat ]
- bi
-
- >r 1 invert-index pluck r> ! remove the last append/compose
-
- [starter] prepend
-
- append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: [bake] ( seq -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: bake ( seq -- quot ) [bake] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing
-: `V{ \ } [ >vector ] parse-literal \ bake parsed ; parsing
-: `[ \ ] [ >quotation ] parse-literal \ bake parsed ; parsing
\ No newline at end of file
+++ /dev/null
-
-USING: tools.test math prettyprint kernel io arrays vectors sequences
- generalizations bake bake.fry ;
-
-IN: bake.fry.tests
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: unit-test* ( input output -- ) swap unit-test ;
-
-: must-be-t ( in -- ) [ t ] swap unit-test ;
-: must-be-f ( in -- ) [ f ] swap unit-test ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test
-
-[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test
-
-[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test
-
-[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test
-
-[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
-
-[ [ "a" write "b" print ] ]
-[ "a" "b" '[ , write , print ] ] unit-test
-
-[ [ 1 2 + 3 4 - ] ]
-[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
-
-[ 1/2 ] [
- 1 '[ , _ / ] 2 swap call
-] unit-test
-
-[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [
- 1 '[ , _ _ 3array ]
- { "a" "b" "c" } { "A" "B" "C" } rot 2map
-] unit-test
-
-[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [
- '[ 1 _ 2array ]
- { "a" "b" "c" } swap map
-] unit-test
-
-[ 1 2 ] [
- 1 2 '[ _ , ] call
-] unit-test
-
-[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [
- 1 2 '[ , _ , 3array ]
- { "a" "b" "c" } swap map
-] unit-test
-
-: funny-dip '[ @ _ ] call ; inline
-
-[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
-
-[ { 1 2 3 } ] [
- 3 1 '[ , [ , + ] map ] call
-] unit-test
-
-[ { 1 { 2 { 3 } } } ] [
- 1 2 3 '[ , [ , [ , 1array ] call 2array ] call 2array ] call
-] unit-test
-
-{ 1 1 } [ '[ [ [ , ] ] ] ] must-infer-as
-
-[ { { { 3 } } } ] [
- 3 '[ [ [ , 1array ] call 1array ] call 1array ] call
-] unit-test
-
-[ { { { 3 } } } ] [
- 3 '[ [ [ , 1array ] call 1array ] call 1array ] call
-] unit-test
-
-! [ 10 20 30 40 '[ , V{ , { , } } , ] ] [ [ 10 V{ 20 { 30 } } 40 ] ] unit-test*
-
-[ 10 20 30 40 '[ , V{ , { , } } , ] ]
-[ [ 10 20 30 >r r> 1 narray >r >r r> r> 2 narray >vector 40 ] ]
-unit-test*
-
-[ { 1 2 3 } { 4 5 6 } { 7 8 9 } '[ , { V{ @ } { , } } ] call ]
-[
- { 1 2 3 }
- { V{ 4 5 6 } { { 7 8 9 } } }
-]
-unit-test*
-
+++ /dev/null
-
-USING: kernel combinators arrays vectors quotations sequences splitting
- parser macros sequences.deep
- combinators.short-circuit combinators.conditional bake newfx ;
-
-IN: bake.fry
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: _
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: (shallow-fry)
-DEFER: shallow-fry
-
-: ((shallow-fry)) ( accum quot adder -- result )
- >r shallow-fry r>
- append swap dup empty?
- [ drop ]
- [ [ prepose ] curry append ]
- if ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (shallow-fry) ( accum quot -- result )
- dup empty?
- [ drop 1quotation ]
- [
- unclip
- {
- { \ , [ [ curry ] ((shallow-fry)) ] }
- { \ @ [ [ compose ] ((shallow-fry)) ] }
- [ swap >r suffix r> (shallow-fry) ]
- }
- case
- ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: deep-fry ( quot -- quot )
- { _ } split1-last dup
- [
- shallow-fry [ >r ] rot
- deep-fry [ [ dip ] curry r> compose ] 4array concat
- ]
- [ drop shallow-fry ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bakeable? ( obj -- ? ) { [ array? ] [ vector? ] } 1|| ;
-
-: fry-specifier? ( obj -- ? ) { , @ } member-of? ;
-
-: count-inputs ( quot -- n ) flatten [ fry-specifier? ] count ;
-
-: commas ( n -- seq ) , <repetition> ;
-
-: [fry] ( quot -- quot' )
- [
- {
- { [ callable? ] [ [ count-inputs commas ] [ [fry] ] bi append ] }
- { [ bakeable? ] [ [ count-inputs commas ] [ [bake] ] bi append ] }
- { [ drop t ] [ 1quotation ] }
- }
- 1cond
- ]
- map concat deep-fry ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: fry ( seq -- quot ) [fry] ;
-
-: '[ \ ] [ >quotation ] parse-literal \ fry parsed ; parsing
+++ /dev/null
-Bake is similar to make but with additional features
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-USING: help.markup help.syntax ;
-IN: bitfields
-
-HELP: BITFIELD:
-{ $syntax "BITFIELD: name slot:size... ;" }
-{ $values { "name" "name of bitfield" } { "slot" "names of slots" } { "size" "sizes of slots" } }
-{ $description "Creates a new bitfield specification, with the constructor <name> and slot accessors of the form name-slot. Slots' values can be changed by words of the form with-name-slot, with the stack effect " { $code "( newvalue bitfield -- newbitfield )" } ". The slots have the amount of space specified, in bits, after the colon. The constructor and setters do not check to make sure there is no overflow, and any inappropriately high value (except in the first field) will corrupt the bitfield. To check overflow, use " { $link POSTPONE: SAFE-BITFIELD: } " instead. Padding can be included by writing the binary number to be used as a pad in the middle of the bitfield specification. The first slot written will have the most significant digits. Note that bitfields do not form a class; they are merely integers. For efficiency across platforms, it is often the best to keep the total size at or below 29, allowing fixnums to be used on all platforms." }
-{ $see-also define-bitfield } ;
-
-HELP: define-bitfield
-{ $values { "classname" "a string" } { "slots" "slot specifications" } }
-{ $description "Defines a bitfield constructor and slot accessors and setters. The workings of these are described in more detail at " { $link POSTPONE: BITFIELD: } ". The slot specifications should be an assoc. Any key which looks like a binary number will be treated as padding." } ;
-
-HELP: SAFE-BITFIELD:
-{ $syntax "SAFE-BITFIELD: name slot:size... ;" }
-{ $values { "name" "name of bitfield" } { "slot" "name of slots" } { "size" "size in bits of slots" } }
-{ $description "Defines a bitfield in the same way as " { $link POSTPONE: BITFIELD: } " but the constructor and slot setters check for overflow." } ;
+++ /dev/null
-USING: tools.test bitfields kernel ;
-IN: bitfields.tests
-
-SAFE-BITFIELD: foo bar:5 baz:10 111 bing:2 ;
-
-[ 21 ] [ 21 852 3 <foo> foo-bar ] unit-test
-[ 852 ] [ 21 852 3 <foo> foo-baz ] unit-test
-[ 3 ] [ 21 852 3 <foo> foo-bing ] unit-test
-
-[ 23 ] [ 21 852 3 <foo> 23 swap with-foo-bar foo-bar ] unit-test
-[ 855 ] [ 21 852 3 <foo> 855 swap with-foo-baz foo-baz ] unit-test
-[ 1 ] [ 21 852 3 <foo> 1 swap with-foo-bing foo-bing ] unit-test
-
-[ 100 0 0 <foo> ] must-fail
-[ 0 5000 0 <foo> ] must-fail
-[ 0 0 10 <foo> ] must-fail
-
-[ 100 0 with-foo-bar ] must-fail
-[ 5000 0 with-foo-baz ] must-fail
-[ 10 0 with-foo-bing ] must-fail
-
-[ BIN: 00101100000000111111 ] [ BIN: 101 BIN: 1000000001 BIN: 11 <foo> ] unit-test
+++ /dev/null
-USING: parser lexer kernel math sequences namespaces make assocs
-summary words splitting math.parser arrays sequences.next
-mirrors generalizations compiler.units ;
-IN: bitfields
-
-! Example:
-! BITFIELD: blah short:16 char:8 nothing:5 ;
-! defines <blah> blah-short blah-char blah-nothing.
-
-! An efficient bitfield has a sum of 29 bits or less
-! so it can fit in a fixnum.
-! No class is defined and there is no overflow checking.
-! The first field is the most significant.
-
-: >ranges ( slots/sizes -- slots/ranges )
- ! range is { start length }
- reverse 0 swap [
- swap >r tuck >r [ + ] keep r> 2array r> swap
- ] assoc-map nip reverse ;
-
-SYMBOL: safe-bitfields? ! default f; set at parsetime
-
-TUPLE: check< number bound ;
-M: check< summary drop "Number exceeds upper bound" ;
-
-: check< ( num cmp -- num )
- 2dup < [ drop ] [ \ check< boa throw ] if ;
-
-: ?check ( length -- )
- safe-bitfields? get [ 2^ , \ check< , ] [ drop ] if ;
-
-: put-together ( lengths -- )
- ! messy because of bounds checking
- dup length 1- [ \ >r , ] times [ 0 swap ] % [
- ?check [ \ bitor , , [ shift r> ] % ] when*
- ] each-next \ bitor , ;
-
-: padding-name? ( string -- ? )
- [ "10" member? ] all? ;
-
-: pad ( i name -- )
- bin> , , \ -nrot , ;
-
-: add-padding ( names -- )
- <enum>
- [ dup padding-name? [ pad ] [ 2drop ] if ] assoc-each ;
-
-: [constructor] ( names lengths -- quot )
- [ swap add-padding put-together ] [ ] make ;
-
-: define-constructor ( classname slots -- )
- [ keys ] keep values [constructor]
- >r in get constructor-word dup save-location r>
- define ;
-
-: range>accessor ( range -- quot )
- [
- dup first neg , \ shift ,
- second 2^ 1- , \ bitand ,
- ] [ ] make ;
-
-: [accessors] ( lengths -- accessors )
- [ range>accessor ] map ;
-
-: clear-range ( range -- num )
- first2 dupd + [ 2^ 1- ] bi@ bitnot bitor ;
-
-: range>setter ( range -- quot )
- [
- \ >r , dup second ?check \ r> ,
- dup clear-range ,
- [ bitand >r ] %
- first , [ shift r> bitor ] %
- ] [ ] make ;
-
-: [setters] ( lengths -- setters )
- [ range>setter ] map ;
-
-: parse-slots ( slotspecs -- slots )
- [ ":" split1 string>number [ dup length ] unless* ] { } map>assoc ;
-
-: define-slots ( prefix names quots -- )
- >r [ "-" glue create-in ] with map r>
- [ define ] 2each ;
-
-: define-accessors ( classname slots -- )
- dup values [accessors]
- >r keys r> define-slots ;
-
-: define-setters ( classname slots -- )
- >r "with-" prepend r>
- dup values [setters]
- >r keys r> define-slots ;
-
-: filter-pad ( slots -- slots )
- [ drop padding-name? not ] assoc-filter ;
-
-: define-bitfield ( classname slots -- )
- [
- [ define-constructor ] 2keep
- >ranges filter-pad [ define-setters ] 2keep define-accessors
- ] with-compilation-unit ;
-
-: parse-bitfield ( -- )
- scan ";" parse-tokens parse-slots define-bitfield ;
-
-: BITFIELD:
- parse-bitfield ; parsing
-
-: SAFE-BITFIELD:
- [ safe-bitfields? on parse-bitfield ] with-scope ; parsing
+++ /dev/null
-Simple system for specifying packed bitfields
+++ /dev/null
-extensions
+++ /dev/null
-Adam Wendt
+++ /dev/null
-
-USING: kernel namespaces math.vectors opengl pos ori turtle self ;
-
-IN: opengl.camera
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: camera-eye ( -- point ) pos> ;
-
-: camera-focus ( -- point ) [ 1 step-turtle pos> ] save-self ;
-
-: camera-up ( -- dirvec )
-[ 90 pitch-up pos> 1 step-turtle pos> swap v- ] save-self ;
-
-: do-look-at ( camera -- )
-[ >self camera-eye camera-focus camera-up gl-look-at ] with-scope ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: help.syntax help.markup kernel prettyprint sequences
-quotations math ;
-IN: combinators.lib
-
-HELP: generate
-{ $values { "generator" quotation } { "predicate" quotation } { "obj" object } }
-{ $description "Loop until the generator quotation generates an object that satisfies predicate quotation." }
-{ $unchecked-example
- "! Generate a random 20-bit prime number congruent to 3 (mod 4)"
- "USING: combinators.lib math math.miller-rabin prettyprint ;"
- "[ 20 random-prime ] [ 4 mod 3 = ] generate ."
- "526367"
-} ;
-
-HELP: %chance
-{ $values { "quot" quotation } { "n" integer } }
-{ $description "Calls the quotation " { $snippet "n" } " percent of the time." }
-{ $unchecked-example
- "USING: io ;"
- "[ \"hello, world! maybe.\" print ] 50 %chance"
- ""
-} ;
+++ /dev/null
-USING: combinators.lib kernel math random sequences tools.test continuations
- arrays vectors ;
-IN: combinators.lib.tests
-
-[ 6 -1 ] [ 5 0 1 [ + ] [ - ] bi, bi* ] unit-test
-[ 6 -1 1 ] [ 5 0 1 1 [ + ] [ - ] [ * ] tri, tri* ] unit-test
-
-[ 5 4 ] [ 5 0 1 [ + ] [ - ] bi*, bi ] unit-test
-[ 5 4 5 ] [ 5 0 1 1 [ + ] [ - ] [ * ] tri*, tri ] unit-test
-
-[ 5 6 ] [ 5 0 1 [ + ] bi@, bi ] unit-test
-[ 5 6 7 ] [ 5 0 1 2 [ + ] tri@, tri ] unit-test
-
-[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
-[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
-
-[ { "foo" "xbarx" } ]
-[
- { "oof" "bar" } { [ reverse ] [ "x" dup surround ] } parallel-call
-] unit-test
-
-{ 1 1 } [
- [ even? ] [ drop 1 ] [ drop 2 ] ifte
-] must-infer-as
+++ /dev/null
-! Copyright (C) 2007, 2008 Slava Pestov, Chris Double,
-! Doug Coleman, Eduardo Cavazos,
-! Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel combinators fry namespaces make quotations hashtables
-sequences assocs arrays stack-checker effects math math.ranges
-generalizations macros continuations random locals accessors ;
-
-IN: combinators.lib
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Currying cleave combinators
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bi, ( obj quot quot -- quot' quot' )
- [ [ curry ] curry ] bi@ bi ; inline
-: tri, ( obj quot quot quot -- quot' quot' quot' )
- [ [ curry ] curry ] tri@ tri ; inline
-
-: bi*, ( obj obj quot quot -- quot' quot' )
- [ [ curry ] curry ] bi@ bi* ; inline
-: tri*, ( obj obj obj quot quot quot -- quot' quot' quot' )
- [ [ curry ] curry ] tri@ tri* ; inline
-
-: bi@, ( obj obj quot -- quot' quot' )
- [ curry ] curry bi@ ; inline
-: tri@, ( obj obj obj quot -- quot' quot' quot' )
- [ curry ] curry tri@ ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Generalized versions of core combinators
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: quad ( x p q r s -- ) [ keep ] 3dip [ keep ] 2dip [ keep ] dip call ; inline
-
-: 4slip ( quot a b c d -- a b c d ) 4 nslip ; inline
-
-: 4keep ( w x y z quot -- w x y z ) 4 nkeep ; inline
-
-: 2with ( param1 param2 obj quot -- obj curry )
- with with ; inline
-
-: 3with ( param1 param2 param3 obj quot -- obj curry )
- with with with ; inline
-
-: with* ( obj assoc quot -- assoc curry )
- swapd [ [ -rot ] dip call ] 2curry ; inline
-
-: 2with* ( obj1 obj2 assoc quot -- assoc curry )
- with* with* ; inline
-
-: 3with* ( obj1 obj2 obj3 assoc quot -- assoc curry )
- with* with* with* ; inline
-
-: assoc-each-with ( obj assoc quot -- )
- with* assoc-each ; inline
-
-: assoc-map-with ( obj assoc quot -- assoc )
- with* assoc-map ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! ifte
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: preserving ( predicate -- quot )
- dup infer in>>
- dup 1+
- '[ _ _ nkeep _ nrot ] ;
-
-MACRO: ifte ( quot quot quot -- )
- '[ _ preserving _ _ if ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! switch
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: switch ( quot -- )
- [ [ [ preserving ] curry ] dip ] assoc-map
- [ cond ] curry ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Conceptual implementation:
-
-! : pcall ( seq quots -- seq ) [ call ] 2map ;
-
-MACRO: parallel-call ( quots -- )
- [ '[ [ unclip @ ] dip [ push ] keep ] ] map concat
- '[ V{ } clone @ nip >array ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! map-call and friends
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (make-call-with) ( quots -- quot )
- [ [ keep ] curry ] map concat [ drop ] append ;
-
-MACRO: map-call-with ( quots -- )
- [ (make-call-with) ] keep length [ narray ] curry compose ;
-
-: (make-call-with2) ( quots -- quot )
- [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
- [ 2drop ] append ;
-
-MACRO: map-call-with2 ( quots -- )
- [
- [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
- [ 2drop ] append
- ] keep length [ narray ] curry append ;
-
-MACRO: map-exec-with ( words -- )
- [ 1quotation ] map [ map-call-with ] curry ;
-
-MACRO: construct-slots ( assoc tuple-class -- tuple )
- [ new ] curry swap [
- [ dip ] curry swap 1quotation [ keep ] curry compose
- ] { } assoc>map concat compose ;
-
-: 2quot-with ( obj seq quot1 quot2 -- seq quot1 quot2 )
- >r pick >r with r> r> swapd with ;
-
-MACRO: multikeep ( word out-indexes -- ... )
- [
- dup >r [ \ npick \ >r 3array % ] each
- %
- r> [ drop \ r> , ] each
- ] [ ] make ;
-
-: generate ( generator predicate -- obj )
- '[ dup @ dup [ nip ] unless ]
- swap do until ;
-
-MACRO: predicates ( seq -- quot/f )
- dup [ 1quotation [ drop ] prepend ] map
- [ [ [ dup ] prepend ] map ] dip zip [ drop f ] suffix
- [ cond ] curry ;
-
-: %chance ( quot n -- ) 100 random > swap when ; inline
--- /dev/null
+
+USING: arrays assocs compiler.units
+ grouping help help.markup help.topics kernel lexer multiline
+ namespaces parser sequences splitting words
+ easy-help.expand-markup ;
+
+IN: easy-help
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: parse-text-block ( -- array )
+
+ ".." parse-multiline-string
+ string-lines
+ 1 tail
+ [ dup " " head? [ 4 tail ] [ ] if ] map
+ [ expand-markup ] map
+ concat
+ [ dup "" = [ drop { $nl } ] [ ] if ] map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: Text: parse-text-block parsed ; parsing
+
+: Block: scan-word 1array parse-text-block append parsed ; parsing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: Notes: { $notes } parse-text-block append parsed ; parsing
+: Description: { $description } parse-text-block append parsed ; parsing
+: Contract: { $contract } parse-text-block append parsed ; parsing
+: Checked-Example: { $example } parse-text-block append parsed ; parsing
+
+: Class-Description:
+ { $class-description } parse-text-block append parsed ; parsing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: Code:
+
+ { $code }
+ parse-text-block [ dup array? [ drop "" ] [ ] if ] map
+ append
+ parsed
+
+ ; parsing
+
+: Example:
+ { $heading "Example" }
+ { $code }
+ parse-text-block
+ [ dup array? [ drop "" ] [ ] if ] map ! Each item in $code must be a string
+ append
+ 2array parsed ; parsing
+
+: Introduction:
+
+ { $heading "Introduction" }
+ parse-text-block
+ 2array parsed ; parsing
+
+: Summary:
+
+ { $heading "Summary" }
+ parse-text-block
+ 2array parsed ; parsing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: Values:
+
+ ".." parse-multiline-string
+ string-lines
+ 1 tail
+ [ dup " " head? [ 4 tail ] [ ] if ] map
+ [ " " split1 [ " " first = ] trim-head 2array ] map
+ \ $values prefix
+ parsed
+
+ ; parsing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: Word:
+
+ scan current-vocab create dup old-definitions get
+ [ delete-at ] with each dup set-word
+
+ bootstrap-word dup set-word
+ dup >link save-location
+ \ ; parse-until >array swap set-word-help ; parsing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: Heading: { $heading } ".." parse-multiline-string suffix parsed ; parsing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: List:
+
+ { $list }
+
+ ".." parse-multiline-string
+ string-lines
+ 1 tail
+ [ dup " " head? [ 4 tail ] [ ] if ] map
+ [ expand-markup ] map
+
+ append parsed
+
+ ; parsing
--- /dev/null
+
+USING: accessors arrays kernel lexer locals math namespaces parser
+ sequences splitting ;
+
+IN: easy-help.expand-markup
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: scan-one-array ( string -- array rest )
+ string-lines
+ lexer-factory get call
+ [
+ [
+ \ } parse-until >array
+ lexer get line-text>>
+ lexer get column>> tail
+ ]
+ with-lexer
+ ]
+ with-scope ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: contains-markup? ( string -- ? ) "{ $" swap subseq? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: expand-markup ( LINE -- lines )
+
+ LINE contains-markup?
+ [
+
+ [let | N [ "{ $" LINE start ] |
+
+ LINE N head
+
+ LINE N 2 + tail scan-one-array dup " " head? [ 1 tail ] [ ] if
+
+ [ 2array ] dip
+
+ expand-markup
+
+ append ]
+
+ ]
+ [ LINE 1array ]
+ if ;
+++ /dev/null
-! Simple IRC bot written in Factor.
-
-REQUIRES: apps/http-server ;
-
-USING: errors generic hashtables help html http io kernel math
-memory namespaces parser prettyprint sequences strings threads
-words inspector network ;
-IN: factorbot
-
-SYMBOL: irc-stream
-SYMBOL: nickname
-SYMBOL: speaker
-SYMBOL: receiver
-
-: irc-write ( s -- ) irc-stream get stream-write ;
-: irc-print ( s -- )
- irc-stream get stream-print
- irc-stream get stream-flush ;
-
-: nick ( nick -- )
- dup nickname set "NICK " irc-write irc-print ;
-
-: login ( nick -- )
- dup nick
- "USER " irc-write irc-write
- " hostname servername :irc.factor" irc-print ;
-
-: connect ( server -- ) 6667 <inet> <client> irc-stream set ;
-
-: disconnect ( -- ) irc-stream get stream-close ;
-
-: join ( chan -- )
- "JOIN " irc-write irc-print ;
-
-GENERIC: handle-irc ( line -- )
-PREDICATE: string privmsg " " split1 nip "PRIVMSG" head? ;
-PREDICATE: string ping "PING" head? ;
-
-M: object handle-irc ( line -- )
- drop ;
-
-: parse-privmsg ( line -- text )
- " " split1 nip
- "PRIVMSG " ?head drop
- " " split1 swap receiver set
- ":" ?head drop ;
-
-M: privmsg handle-irc ( line -- )
- parse-privmsg
- " " split1 swap
- "factorbot-commands" lookup dup
- [ execute ] [ 2drop ] if ;
-
-M: ping handle-irc ( line -- )
- "PING " ?head drop "PONG " swap append irc-print ;
-
-: parse-irc ( line -- )
- ":" ?head [ "!" split1 swap speaker set ] when handle-irc ;
-
-: say ( line nick -- )
- "PRIVMSG " irc-write irc-write " :" irc-write irc-print ;
-
-: respond ( line -- )
- receiver get nickname get = speaker receiver ? get say ;
-
-: irc-loop ( -- )
- irc-stream get stream-readln
- [ dup print flush parse-irc irc-loop ] when* ;
-
-: factorbot
- "irc.freenode.net" connect
- "factorbot" login
- "#concatenative" join
- [ irc-loop ] [ irc-stream get stream-close ] cleanup ;
-
-: factorbot-loop [ factorbot ] try 30000 sleep factorbot-loop ;
-
-: multiline-respond ( string -- )
- string-lines [ respond ] each ;
-
-: object-href
- "http://factorcode.org" swap browser-link-href append ;
-
-: not-found ( str -- )
- "Sorry, I couldn't find anything for " swap append respond ;
-
-IN: factorbot-commands
-
-: see ( text -- )
- dup words-named dup empty? [
- drop
- not-found
- ] [
- nip [
- dup summary " -- "
- rot object-href 3append respond
- ] each
- ] if ;
-
-: memory ( text -- )
- drop [ room. ] with-string-writer multiline-respond ;
-
-: quit ( text -- )
- drop speaker get "slava" = [ disconnect ] when ;
-
-PROVIDE: apps/factorbot ;
-
-MAIN: apps/factorbot factorbot ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: kernel combinators sequences math math.functions math.vectors mortar
- slot-accessors x x.widgets.wm.root x.widgets.wm.frame sequences.lib ;
-IN: factory.commands
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: up-till-frame ( window -- wm-frame )
-{ { [ dup <wm-frame> is? ]
- [ ] }
- { [ dup $dpy $default-root $id over $id = ]
- [ drop f ] }
- { [ t ]
- [ <- parent up-till-frame ] } } cond ;
-
-: pointer-window ( -- window ) dpy> <- pointer-window ;
-
-: pointer-frame ( -- wm-frame )
-pointer-window up-till-frame dup <wm-frame> is? [ ] [ drop f ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: maximize ( -- ) pointer-frame wm-frame-maximize drop ;
-
-: minimize ( -- ) pointer-frame <- unmap drop ;
-
-: maximize-vertical ( -- ) pointer-frame wm-frame-maximize-vertical drop ;
-
-: restore ( -- ) pointer-frame <- restore-state drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
-
-: tile-master ( -- )
-
-wm-root>
- <- children
- [ <- mapped? ] filter
- [ check-window-table ] map
- reverse
-
-unclip
- { 0 0 } <-- move
- wm-root> <- size { 1/2 1 } v*
- [ floor ] map <-- resize
- <- adjust-child
-drop
-
-dup empty? [ drop ] [
-
-wm-root> <- width 2 / floor [ <-- set-width ] curry map
-wm-root> <- height over length / floor [ <-- set-height ] curry map
-
-wm-root> <- width 2 / floor [ <-- set-x ] curry map
-
-wm-root> <- height over length / over length [ * floor ] map-with
-[ <-- set-y <- adjust-child ] 2map
-
-drop
-
-] if ;
-
-! : tile-master ( -- )
-
-! wm-root>
-! <- children
-! [ <- mapped? ] filter
-! [ check-window-table ] map
-! reverse
-
-! { { [ dup empty? ] [ drop ] }
-! { [ dup length 1 = ] [ drop maximize ] }
-! { [ t ] [ tile-master* ] }
+++ /dev/null
-! -*-factor-*-
-
-USING: kernel unix vars mortar mortar.sugar slot-accessors
- x.widgets.wm.menu x.widgets.wm.unmapped-frames-menu
- factory.commands factory.load ;
-
-IN: factory
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Helper words
-
-: new-wm-menu ( -- menu ) <wm-menu> new* 1 <-- set-border-width ;
-
-: shrink-wrap ( menu -- ) dup <- calc-size <-- resize drop ;
-
-: set-menu-items ( items menu -- ) swap >>items shrink-wrap ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: apps-menu
-
-apps-menu> not [ new-wm-menu >apps-menu ] when
-
-{ { "Emacs" [ "emacs &" system drop ] }
- { "KMail" [ "kmail &" system drop ] }
- { "Akregator" [ "akregator &" system drop ] }
- { "Amarok" [ "amarok &" system drop ] }
- { "K3b" [ "k3b &" system drop ] }
- { "xchat" [ "xchat &" system drop ] }
- { "Nautilus" [ "nautilus --no-desktop &" system drop ] }
- { "synaptic" [ "gksudo synaptic &" system drop ] }
- { "Volume control" [ "gnome-volume-control &" system drop ] }
- { "Azureus" [ "~/azureus/azureus &" system drop ] }
- { "Xephyr" [ "Xephyr -host-cursor :1 &" system drop ] }
- { "Stop Xephyr" [ "pkill Xephyr &" system drop ] }
- { "Stop Firefox" [ "pkill firefox &" system drop ] }
-} apps-menu> set-menu-items
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: emacs-menu
-
-emacs-menu> not [ new-wm-menu >emacs-menu ] when
-
-{ { "Start Emacs" [ "emacs &" system drop ] }
- { "Small" [ "emacsclient -e '(make-small-frame-command)' &" system drop ] }
- { "Large" [ "emacsclient -e '(make-frame-command)' &" system drop ] }
- { "Full" [ "emacsclient -e '(make-full-frame-command)' &" system drop ] }
- { "Gnus" [ "emacsclient -e '(gnus-other-frame)' &" system drop ] }
- { "Factor" [ "emacsclient -e '(run-factor-other-frame)' &" system drop ] }
-} emacs-menu> set-menu-items
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: mail-menu
-
-mail-menu> not [ new-wm-menu >mail-menu ] when
-
-{ { "Kmail" [ "kmail &" system drop ] }
- { "compose" [ "kmail --composer &" system drop ] }
- { "slava" [ "kmail slava@factorcode.org &" system drop ] }
- { "erg" [ "kmail doug.coleman@gmail.com &" system drop ] }
- { "doublec" [ "kmail chris.double@double.co.nz &" system drop ] }
- { "yuuki" [ "kmail matthew.willis@mac.com &" system drop ] }
-} mail-menu> set-menu-items
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: factor-menu
-
-factor-menu> not [ new-wm-menu >factor-menu ] when
-
-{ { "Factor" [ "cd /scratch/repos/Factor ; ./factor &" system drop ] }
- { "Factor (tty)"
- [ "cd /scratch/repos/Factor ; xterm -e ./factor -run=listener &"
- system drop ] }
- { "Terminal : repos/Factor"
- [ "cd /scratch/repos/Factor ; xterm &" system drop ] }
- { "darcs whatsnew"
- [ "cd /scratch/repos/Factor ; xterm -e 'darcs whatsnew | less' &"
- system drop ] }
- { "darcs pull"
- [ "cd /scratch/repos/Factor ; xterm -e 'darcs pull http://factorcode.org/repos' &" system drop ] }
- { "darcs push"
- [ "cd /scratch/repos/Factor ; xterm -e 'darcs push dharmatech@onigirihouse.com:doc-root/repos' &" system drop ] }
-} factor-menu> set-menu-items
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: factory-menu
-
-factory-menu> not [ new-wm-menu >factory-menu ] when
-
-{ { "Maximize" [ maximize ] }
- { "Maximize Vertical" [ maximize-vertical ] }
- { "Restore" [ restore ] }
- { "Hide" [ minimize ] }
- { "Tile Master" [ tile-master ] }
-}
-
-factory-menu> set-menu-items
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! VAR: root-menu
-
-{ { "xterm" [ "urxvt -bd grey +sb &" system drop ] }
- { "Firefox" [ "firefox &" system drop ] }
- { "xclock" [ "xclock &" system drop ] }
- { "Apps >" [ apps-menu> <- popup ] }
- { "Factor >" [ factor-menu> <- popup ] }
- { "Unmapped frames >" [ unmapped-frames-menu> <- popup ] }
- { "Emacs >" [ emacs-menu> <- popup ] }
- { "Mail >" [ mail-menu> <- popup ] }
- { "onigirihouse" [ "xterm -e 'ssh dharmatech@onigirihouse.com' &"
- system drop ] }
- { "Edit menus" [ edit-factory-menus ] }
- { "Reload menus" [ load-factory-menus ] }
- { "Factory >" [ factory-menu> <- popup ] }
-} root-menu> set-menu-items
-
+++ /dev/null
-! -*-factor-*-
-
-USING: kernel mortar x
- x.widgets.wm.root
- x.widgets.wm.workspace
- x.widgets.wm.unmapped-frames-menu
- factory.load
- tty-server ;
-
-IN: factory
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-create-root-menu
-create-unmapped-frames-menu
-load-factory-menus
-6 setup-workspaces
-
-wm-root>
- no-modifiers "F12" [ root-menu> <- popup ] <---- set-key-action
- control-alt "LEFT" [ prev-workspace ] <---- set-key-action
- control-alt "RIGHT" [ next-workspace ] <---- set-key-action
- alt "TAB" [ circulate-focus ] <---- set-key-action
-drop
-
-9010 tty-server
+++ /dev/null
-
-USING: kernel parser io io.files namespaces sequences editors threads vars
- mortar mortar.sugar slot-accessors
- x
- x.widgets.wm.root
- x.widgets.wm.frame
- x.widgets.wm.menu
- factory.load
- factory.commands ;
-
-IN: factory
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: manage-windows ( -- )
-dpy get $default-root <- children [ <- mapped? ] filter
-[ $id <wm-frame> new* drop ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: root-menu
-
-: create-root-menu ( -- ) <wm-menu> new* 1 <-- set-border-width >root-menu ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start-factory ( display-string -- )
-<display> new* >dpy
-install-default-error-handler
-create-wm-root
-init-atoms
-manage-windows
-load-factory-rc ;
-
-: factory ( -- ) f start-factory stop ;
-
-MAIN: factory
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel io.files parser editors sequences ;
-
-IN: factory.load
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: file-or ( file file -- file ) over exists? [ drop ] [ nip ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: personal-factory-rc ( -- path ) home "/.factory-rc" append ;
-
-: system-factory-rc ( -- path ) "extra/factory/factory-rc" resource-path ;
-
-: factory-rc ( -- path ) personal-factory-rc system-factory-rc file-or ;
-
-: load-factory-rc ( -- ) factory-rc run-file ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: personal-factory-menus ( -- path ) home "/.factory-menus" append ;
-
-: system-factory-menus ( -- path )
-"extra/factory/factory-menus" resource-path ;
-
-: factory-menus ( -- path )
-personal-factory-menus system-factory-menus file-or ;
-
-: load-factory-menus ( -- ) factory-menus run-file ;
-
-: edit-factory-menus ( -- ) factory-menus 0 edit-location ;
+++ /dev/null
-Window manager for the X Window System
+++ /dev/null
-applications
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: alien.syntax ;
-IN: unix.linux.fs
-
-: MS_RDONLY 1 ; ! Mount read-only.
-: MS_NOSUID 2 ; ! Ignore suid and sgid bits.
-: MS_NODEV 4 ; ! Disallow access to device special files.
-: MS_NOEXEC 8 ; ! Disallow program execution.
-: MS_SYNCHRONOUS 16 ; ! Writes are synced at once.
-: MS_REMOUNT 32 ; ! Alter flags of a mounted FS.
-: MS_MANDLOCK 64 ; ! Allow mandatory locks on an FS.
-: S_WRITE 128 ; ! Write on file/directory/symlink.
-: S_APPEND 256 ; ! Append-only file.
-: S_IMMUTABLE 512 ; ! Immutable file.
-: MS_NOATIME 1024 ; ! Do not update access times.
-: MS_NODIRATIME 2048 ; ! Do not update directory access times.
-: MS_BIND 4096 ; ! Bind directory at different place.
-
-FUNCTION: int mount
-( char* special_file, char* dir, char* fstype, ulong options, void* data ) ;
-
-! FUNCTION: int umount2 ( char* file, int flags ) ;
-
-FUNCTION: int umount ( char* file ) ;
+++ /dev/null
-unportable
+++ /dev/null
-Alex Chapman
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: assocs kernel gap-buffer.cursortree tools.test sequences trees
-arrays strings ;
-IN: gap-buffer.cursortree.tests
-
-[ t ] [ "this is a test string" <cursortree> 0 <left-cursor> at-beginning? ] unit-test
-[ t ] [ "this is a test string" <cursortree> dup length <left-cursor> at-end? ] unit-test
-[ 3 ] [ "this is a test string" <cursortree> 3 <left-cursor> cursor-pos ] unit-test
-[ CHAR: i ] [ "this is a test string" <cursortree> 3 <left-cursor> element< ] unit-test
-[ CHAR: s ] [ "this is a test string" <cursortree> 3 <left-cursor> element> ] unit-test
-[ t ] [ "this is a test string" <cursortree> 3 <left-cursor> CHAR: a over set-element< CHAR: t over set-element> cursor-tree "that is a test string" sequence= ] unit-test
-[ 0 ] [ "this is a test string" <cursortree> dup dup 3 <left-cursor> remove-cursor cursors length ] unit-test
-[ t ] [ "this is a test string" <cursortree> 3 <left-cursor> 8 over set-cursor-pos dup 1array swap cursor-tree cursors sequence= ] unit-test
-[ "this is no longer a test string" ] [ "this is a test string" <cursortree> 8 <left-cursor> "no longer " over insert cursor-tree >string ] unit-test
-[ "refactor" ] [ "factor" <cursortree> 0 <left-cursor> CHAR: e over insert CHAR: r over insert cursor-tree >string ] unit-test
-[ "refactor" ] [ "factor" <cursortree> 0 <right-cursor> CHAR: r over insert CHAR: e over insert cursor-tree >string ] unit-test
-[ "this a test string" 5 ] [ "this is a test string" <cursortree> 5 <right-cursor> dup delete> dup delete> dup delete> dup cursor-tree >string swap cursor-pos ] unit-test
-[ "this a test string" 5 ] [ "this is a test string" <cursortree> 8 <right-cursor> dup delete< dup delete< dup delete< dup cursor-tree >string swap cursor-pos ] unit-test
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman All Rights Reserved.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel gap-buffer generic trees trees.avl math
-sequences quotations ;
-IN: gap-buffer.cursortree
-
-TUPLE: cursortree cursors ;
-
-: <cursortree> ( seq -- cursortree )
- <gb> cursortree new tuck set-delegate <avl>
- over set-cursortree-cursors ;
-
-GENERIC: cursortree-gb ( cursortree -- gb )
-M: cursortree cursortree-gb ( cursortree -- gb ) delegate ;
-GENERIC: set-cursortree-gb ( gb cursortree -- )
-M: cursortree set-cursortree-gb ( gb cursortree -- ) set-delegate ;
-
-TUPLE: cursor i tree ;
-TUPLE: left-cursor ;
-TUPLE: right-cursor ;
-
-: cursor-index ( cursor -- i ) cursor-i ;
-
-: add-cursor ( cursortree cursor -- ) dup cursor-index rot push-at ;
-
-: remove-cursor ( cursortree cursor -- )
- tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ;
-
-: set-cursor-index ( index cursor -- )
- dup cursor-tree over remove-cursor tuck set-cursor-i
- dup cursor-tree cursortree-cursors swap add-cursor ;
-
-GENERIC: cursor-pos ( cursor -- n )
-GENERIC: set-cursor-pos ( n cursor -- )
-M: left-cursor cursor-pos ( cursor -- n ) [ cursor-i 1+ ] keep cursor-tree index>position ;
-M: right-cursor cursor-pos ( cursor -- n ) [ cursor-i ] keep cursor-tree index>position ;
-M: left-cursor set-cursor-pos ( n cursor -- ) >r 1- r> [ cursor-tree position>index ] keep set-cursor-index ;
-M: right-cursor set-cursor-pos ( n cursor -- ) [ cursor-tree position>index ] keep set-cursor-index ;
-
-: <cursor> ( cursortree -- cursor )
- cursor new tuck set-cursor-tree ;
-
-: make-cursor ( cursortree pos cursor -- cursor )
- >r swap <cursor> r> tuck set-delegate tuck set-cursor-pos ;
-
-: <left-cursor> ( cursortree pos -- left-cursor )
- left-cursor new make-cursor ;
-
-: <right-cursor> ( cursortree pos -- right-cursor )
- right-cursor new make-cursor ;
-
-: cursors ( cursortree -- seq )
- cursortree-cursors values concat ;
-
-: cursor-positions ( cursortree -- seq )
- cursors [ cursor-pos ] map ;
-
-M: cursortree move-gap ( n cursortree -- )
- #! Get the position of each cursor before the move, then re-set the
- #! position afterwards. This will update any changed cursor indices.
- dup cursor-positions >r tuck cursortree-gb move-gap
- cursors r> swap [ set-cursor-pos ] 2each ;
-
-: element@< ( cursor -- pos cursortree ) [ cursor-pos 1- ] keep cursor-tree ;
-: element@> ( cursor -- pos cursortree ) [ cursor-pos ] keep cursor-tree ;
-
-: at-beginning? ( cursor -- ? ) cursor-pos 0 = ;
-: at-end? ( cursor -- ? ) element@> length = ;
-
-: insert ( obj cursor -- ) element@> insert* ;
-
-: element< ( cursor -- elem ) element@< nth ;
-: element> ( cursor -- elem ) element@> nth ;
-
-: set-element< ( elem cursor -- ) element@< set-nth ;
-: set-element> ( elem cursor -- ) element@> set-nth ;
-
-GENERIC: fix-cursor ( cursortree cursor -- )
-
-M: left-cursor fix-cursor ( cursortree cursor -- )
- >r gb-gap-start 1- r> set-cursor-index ;
-
-M: right-cursor fix-cursor ( cursortree cursor -- )
- >r gb-gap-end r> set-cursor-index ;
-
-: fix-cursors ( old-gap-end cursortree -- )
- tuck cursortree-cursors at [ fix-cursor ] with each ;
-
-M: cursortree delete* ( pos cursortree -- )
- tuck move-gap dup gb-gap-end swap dup (delete*) fix-cursors ;
-
-: delete< ( cursor -- ) element@< delete* ;
-: delete> ( cursor -- ) element@> delete* ;
-
+++ /dev/null
-Collection of 'cursors' representing locations in a gap buffer
+++ /dev/null
-USING: kernel sequences tools.test gap-buffer strings math ;
-
-! test copy-elements
-[ { 0 3 4 3 4 5 } ] [ { 0 1 2 3 4 5 } dup >r -2 3 5 r> copy-elements ] unit-test
-[ { 0 1 2 1 2 5 } ] [ { 0 1 2 3 4 5 } dup >r 2 2 0 r> copy-elements ] unit-test
-[ "01234567856" ] [ "01234567890" dup >r 4 6 4 r> copy-elements ] unit-test
-
-! test sequence protocol (like, length, nth, set-nth)
-[ "gap buffers are cool" ] [ "gap buffers are cool" <gb> "" like ] unit-test
-
-! test move-gap-back-inside
-[ t f ] [ 5 "0123456" <gb> move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test
-[ "0123456" ] [ "0123456" <gb> 5 over move-gap >string ] unit-test
-! test move-gap-forward-inside
-[ t ] [ "I once ate a spaniel" <gb> 15 over move-gap 17 swap move-gap-forward-inside? 2nip ] unit-test
-[ "I once ate a spaniel" ] [ "I once ate a spaniel" <gb> 15 over move-gap 17 over move-gap >string ] unit-test
-! test move-gap-back-around
-[ f f ] [ 2 "terriers are ok too" <gb> move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test
-[ "terriers are ok too" ] [ "terriers are ok too" <gb> 2 over move-gap >string ] unit-test
-! test move-gap-forward-around
-[ f t ] [ "god is nam's best friend" <gb> 2 over move-gap 22 over position>index swap move-gap-forward? >r move-gap-forward-inside? 2nip r> ] unit-test
-[ "god is nam's best friend" ] [ "god is nam's best friend" <gb> 2 over move-gap 22 over move-gap >string ] unit-test
-
-! test changing buffer contents
-[ "factory" ] [ "factor" <gb> CHAR: y 6 pick insert* >string ] unit-test
-! test inserting multiple elements in different places. buffer should grow
-[ "refractory" ] [ "factor" <gb> CHAR: y 6 pick insert* "re" 0 pick insert* CHAR: r 3 pick insert* >string ] unit-test
-! test deleting elements. buffer should shrink
-[ "for" ] [ "factor" <gb> 3 [ 1 over delete* ] times >string ] unit-test
-! more testing of nth and set-nth
-[ "raptor" ] [ "factor" <gb> CHAR: p 2 pick set-nth 5 over nth 0 pick set-nth >string ] unit-test
-
-! test stack/queue operations
-[ "slaughter" ] [ "laughter" <gb> CHAR: s over push-start >string ] unit-test
-[ "pantonio" ] [ "pant" <gb> "onio" over push-end >string ] unit-test
-[ CHAR: f "actor" ] [ "factor" <gb> dup pop-start swap >string ] unit-test
-[ CHAR: s "pant" ] [ "pants" <gb> dup pop-end swap >string ] unit-test
-[ "end this is the " ] [ "this is the end " <gb> 4 over rotate >string ] unit-test
-[ "your jedi training is finished " ] [ "finished your jedi training is " <gb> -9 over rotate >string ] unit-test
-
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman All Rights Reserved.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain
-! for a good introduction see:
-! http://p-cos.net/lisp-ecoop/submissions/StrandhVilleneuveMoore.pdf
-USING: kernel arrays sequences sequences.private circular math
-math.order math.functions generic ;
-IN: gap-buffer
-
-! gap-start -- the first element of the gap
-! gap-end -- the first element after the gap
-! expand-factor -- should be > 1
-! min-size -- < 5 is not sensible
-
-TUPLE: gb
- gap-start
- gap-end
- expand-factor
- min-size ;
-
-GENERIC: gb-seq ( gb -- seq )
-GENERIC: set-gb-seq ( seq gb -- )
-M: gb gb-seq ( gb -- seq ) delegate ;
-M: gb set-gb-seq ( seq gb -- ) set-delegate ;
-
-: required-space ( n gb -- n )
- tuck gb-expand-factor * ceiling >fixnum swap gb-min-size max ;
-
-: <gb> ( seq -- gb )
- gb new
- 5 over set-gb-min-size
- 1.5 over set-gb-expand-factor
- [ >r length r> set-gb-gap-start ] 2keep
- [ swap length over required-space swap set-gb-gap-end ] 2keep
- [
- over length over required-space rot { } like resize-array <circular> swap set-gb-seq
- ] keep ;
-
-M: gb like ( seq gb -- seq ) drop <gb> ;
-
-: gap-length ( gb -- n ) [ gb-gap-end ] keep gb-gap-start - ;
-
-: buffer-length ( gb -- n ) gb-seq length ;
-
-M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ;
-
-: valid-position? ( pos gb -- ? )
- #! one element past the end of the buffer is a valid position when we're inserting
- length -1 swap between? ;
-
-: valid-index? ( i gb -- ? )
- buffer-length -1 swap between? ;
-
-TUPLE: position-out-of-bounds position gap-buffer ;
-C: <position-out-of-bounds> position-out-of-bounds
-
-: position>index ( pos gb -- i )
- 2dup valid-position? [
- 2dup gb-gap-start >= [
- gap-length +
- ] [ drop ] if
- ] [
- <position-out-of-bounds> throw
- ] if ;
-
-TUPLE: index-out-of-bounds index gap-buffer ;
-C: <index-out-of-bounds> index-out-of-bounds
-
-: index>position ( i gb -- pos )
- 2dup valid-index? [
- 2dup gb-gap-end >= [
- gap-length -
- ] [ drop ] if
- ] [
- <index-out-of-bounds> throw
- ] if ;
-
-M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep gb-seq ;
-
-M: gb nth ( n gb -- elt ) bounds-check virtual@ nth-unsafe ;
-
-M: gb nth-unsafe ( n gb -- elt ) virtual@ nth-unsafe ;
-
-M: gb set-nth ( elt n seq -- ) bounds-check virtual@ set-nth-unsafe ;
-
-M: gb set-nth-unsafe ( elt n seq -- ) virtual@ set-nth-unsafe ;
-
-M: gb virtual-seq gb-seq ;
-
-INSTANCE: gb virtual-sequence
-
-! ------------- moving the gap -------------------------------
-
-: (copy-element) ( to start seq -- ) tuck nth -rot set-nth ;
-
-: copy-element ( dst start seq -- ) >r [ + ] keep r> (copy-element) ;
-
-: copy-elements-back ( dst start seq n -- )
- dup 0 > [
- >r [ copy-element ] 3keep >r 1+ r> r> 1- copy-elements-back
- ] [ 3drop drop ] if ;
-
-: copy-elements-forward ( dst start seq n -- )
- dup 0 > [
- >r [ copy-element ] 3keep >r 1- r> r> 1- copy-elements-forward
- ] [ 3drop drop ] if ;
-
-: copy-elements ( dst start end seq -- )
- pick pick > [
- >r dupd - r> swap copy-elements-forward
- ] [
- >r over - r> swap copy-elements-back
- ] if ;
-
-! the gap can be moved either forward or back. Moving the gap 'inside' means
-! moving elements across the gap. Moving the gap 'around' means changing the
-! start of the circular buffer to avoid moving as many elements.
-
-! We decide which method (inside or around) to pick based on the number of
-! elements that will need to be moved. We always try to move as few elements as
-! possible.
-
-: move-gap? ( i gb -- i gb ? ) 2dup gb-gap-end = not ;
-
-: move-gap-forward? ( i gb -- i gb ? ) 2dup gb-gap-start >= ;
-
-: move-gap-back-inside? ( i gb -- i gb ? )
- #! is it cheaper to move the gap inside than around?
- 2dup [ gb-gap-start swap 2 * - ] keep [ buffer-length ] keep gb-gap-end - <= ;
-
-: move-gap-forward-inside? ( i gb -- i gb ? )
- #! is it cheaper to move the gap inside than around?
- 2dup [ gb-gap-end >r 2 * r> - ] keep [ gb-gap-start ] keep buffer-length + <= ;
-
-: move-gap-forward-inside ( i gb -- )
- [ dup gap-length neg swap gb-gap-end rot ] keep gb-seq copy-elements ;
-
-: move-gap-back-inside ( i gb -- )
- [ dup gap-length swap gb-gap-start 1- rot 1- ] keep gb-seq copy-elements ;
-
-: move-gap-forward-around ( i gb -- )
- 0 over move-gap-back-inside [
- dup buffer-length [
- swap gap-length - neg swap
- ] keep
- ] keep [
- gb-seq copy-elements
- ] keep dup gap-length swap gb-seq change-circular-start ;
-
-: move-gap-back-around ( i gb -- )
- dup buffer-length over move-gap-forward-inside [
- length swap -1
- ] keep [
- gb-seq copy-elements
- ] keep dup length swap gb-seq change-circular-start ;
-
-: move-gap-forward ( i gb -- )
- move-gap-forward-inside? [
- move-gap-forward-inside
- ] [
- move-gap-forward-around
- ] if ;
-
-: move-gap-back ( i gb -- )
- move-gap-back-inside? [
- move-gap-back-inside
- ] [
- move-gap-back-around
- ] if ;
-
-: (move-gap) ( i gb -- )
- move-gap? [
- move-gap-forward? [
- move-gap-forward
- ] [
- move-gap-back
- ] if
- ] [ 2drop ] if ;
-
-: fix-gap ( n gb -- )
- 2dup [ gap-length + ] keep set-gb-gap-end set-gb-gap-start ;
-
-! moving the gap to position 5 means that the element in position 5 will be immediately after the gap
-GENERIC: move-gap ( n gb -- )
-
-M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ;
-
-! ------------ resizing -------------------------------------
-
-: enough-room? ( n gb -- ? )
- #! is there enough room to add 'n' elements to gb?
- tuck length + swap buffer-length <= ;
-
-: set-new-gap-end ( array gb -- )
- [ buffer-length swap length swap - ] keep
- [ gb-gap-end + ] keep set-gb-gap-end ;
-
-: after-gap ( gb -- gb )
- dup gb-seq swap gb-gap-end tail ;
-
-: before-gap ( gb -- gb )
- dup gb-gap-start head ;
-
-: copy-after-gap ( array gb -- )
- #! copy everything after the gap in 'gb' into the end of 'array',
- #! and change 'gb's gap-end to reflect the gap-end in 'array'
- dup after-gap >r 2dup set-new-gap-end gb-gap-end swap r> -rot copy ;
-
-: copy-before-gap ( array gb -- )
- #! copy everything before the gap in 'gb' into the start of 'array'
- before-gap 0 rot copy ; ! gap start doesn't change
-
-: resize-buffer ( gb new-size -- )
- f <array> swap 2dup copy-before-gap 2dup copy-after-gap
- >r <circular> r> set-gb-seq ;
-
-: decrease-buffer-size ( gb -- )
- #! the gap is too big, so resize to something sensible
- dup length over required-space resize-buffer ;
-
-: increase-buffer-size ( n gb -- )
- #! increase the buffer to fit at least 'n' more elements
- tuck length + over required-space resize-buffer ;
-
-: gb-too-big? ( gb -- ? )
- dup buffer-length over gb-min-size > [
- dup length over buffer-length rot gb-expand-factor sq / <
- ] [ drop f ] if ;
-
-: ?decrease ( gb -- )
- dup gb-too-big? [
- decrease-buffer-size
- ] [ drop ] if ;
-
-: ensure-room ( n gb -- )
- #! ensure that ther will be enough room for 'n' more elements
- 2dup enough-room? [ 2drop ] [
- increase-buffer-size
- ] if ;
-
-! ------- editing operations ---------------
-
-GENERIC# insert* 2 ( seq position gb -- )
-
-: prepare-insert ( seq position gb -- seq gb )
- tuck move-gap over length over ensure-room ;
-
-: insert-elements ( seq gb -- )
- dup gb-gap-start swap gb-seq copy ;
-
-: increment-gap-start ( gb n -- )
- over gb-gap-start + swap set-gb-gap-start ;
-
-! generic dispatch identifies numbers as sequences before numbers...
-! M: number insert* ( elem position gb -- ) >r >r 1array r> r> insert* ;
-: number-insert ( num position gb -- ) >r >r 1array r> r> insert* ;
-
-M: sequence insert* ( seq position gb -- )
- pick number? [
- number-insert
- ] [
- prepare-insert [ insert-elements ] 2keep swap length increment-gap-start
- ] if ;
-
-: (delete*) ( gb -- )
- dup gb-gap-end 1+ over set-gb-gap-end ?decrease ;
-
-GENERIC: delete* ( pos gb -- )
-
-M: gb delete* ( position gb -- )
- tuck move-gap (delete*) ;
-
-! -------- stack/queue operations -----------
-
-: push-start ( obj gb -- ) 0 swap insert* ;
-
-: push-end ( obj gb -- ) [ length ] keep insert* ;
-
-: pop-elem ( position gb -- elem ) [ nth ] 2keep delete* ;
-
-: pop-start ( gb -- elem ) 0 swap pop-elem ;
-
-: pop-end ( gb -- elem ) [ length 1- ] keep pop-elem ;
-
-: rotate ( n gb -- )
- dup length 1 > [
- swap dup 0 > [
- [ dup [ pop-end ] keep push-start ]
- ] [
- neg [ dup [ pop-start ] keep push-end ]
- ] if times drop
- ] [ 2drop ] if ;
-
+++ /dev/null
-Gap buffer data structure
+++ /dev/null
-collections
-sequences
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: sequences mortar slot-accessors ;
-
-IN: geom.dim
-
-SYMBOL: <dim>
-
-<dim> { "dim" } accessors define-independent-class
-
-<dim> {
-
-"width" !( dim -- width ) [ $dim first ]
-
-"height" !( dim -- second ) [ $dim second ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel arrays sequences math.vectors mortar slot-accessors ;
-
-IN: geom.pos
-
-SYMBOL: <pos>
-
-<pos> { "pos" } accessors define-independent-class
-
-<pos> {
-
-"x" !( pos -- x ) [ $pos first ]
-
-"y" !( pos -- y ) [ $pos second ]
-
-"set-x" !( pos x -- pos ) [ 0 pick $pos set-nth ]
-
-"set-y" !( pos y -- pos ) [ 1 pick $pos set-nth ]
-
-"distance" !( pos pos -- distance ) [ $pos swap $pos v- norm ]
-
-"move-by" !( pos offset -- pos ) [ over $pos v+ >>pos ]
-
-"move-by-x" !( pos x-offset -- pos ) [ 0 2array <-- move-by ]
-
-"move-by-y" !( pos y-offset -- pos ) [ 0 swap 2array <-- move-by ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences math.vectors
- mortar slot-accessors geom.pos geom.dim ;
-
-IN: geom.rect
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: math
-
-: v+y ( pos y -- pos ) 0 swap 2array v+ ;
-
-: v-y ( pos y -- pos ) 0 swap 2array v- ;
-
-: v+x ( pos x -- pos ) 0 2array v+ ;
-
-: v-x ( pos x -- pos ) 0 2array v- ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: <rect>
-
-<rect>
- <pos> class-slots <dim> class-slots append
- <pos> class-methods <dim> class-methods append { H{ } } append
- { H{ } }
-4array <rect> set-global
-
-! { 0 0 } { 0 0 } <rect> new
-
-<rect> {
-
-"top-left" !( rect -- point ) [ $pos ]
-
-"top-right" !( rect -- point ) [ dup $pos swap <- width 1- v+x ]
-
-"bottom-left" !( rect -- point ) [ dup $pos swap <- height 1- v+y ]
-
-"bottom-right" !( rect -- point ) [ dup $pos swap $dim { 1 1 } v- v+ ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Adam Wendt
+++ /dev/null
-! Coyright (C) 2007 Adam Wendt
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup ;
-IN: id3
-
-ARTICLE: "id3-tags" "ID3 Tags"
-"The " { $vocab-link "id3" } " vocabulary is used to read ID3 tags from MP3 audio streams."
-{ $subsection id3v2 }
-{ $subsection read-tag }
-{ $subsection id3v2? }
-{ $subsection read-id3v2 } ;
-
-ABOUT: "id3-tags"
-
-HELP: id3v2
-{ $values { "filename" "a pathname string" } { "tag/f" "a tag or f" } }
-{ $description "Outputs a " { $link tag } " or " { $link f } " if file does not start with an ID3 tag." } ;
-
-HELP: read-tag
-{ $values { "stream" "a stream" } { "tag/f" "a tag or f" } }
-{ $description "Outputs a " { $link tag } " or " { $link f } " if stream does not start with an ID3 tag." } ;
-
-HELP: id3v2?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if the current input stream begins with an ID3 tag." } ;
-
-HELP: read-id3v2
-{ $values { "tag/f" "a tag or f" } }
-{ $description "Outputs a " { $link tag } " or " { $link f } " if the current input stream does not start with an ID3 tag." } ;
+++ /dev/null
-! Copyright (C) 2007 Adam Wendt.
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: arrays combinators io io.binary io.files io.paths
-io.encodings.utf16 kernel math math.parser namespaces sequences
-splitting strings assocs unicode.categories io.encodings.binary ;
-
-IN: id3
-
-TUPLE: tag header frames ;
-C: <tag> tag
-
-TUPLE: header version revision flags size extended-header ;
-C: <header> header
-
-TUPLE: frame id size flags data ;
-C: <frame> frame
-
-TUPLE: extended-header size flags update crc restrictions ;
-C: <extended-header> extended-header
-
-: debug-stream ( msg -- )
-! global [ . flush ] bind ;
- drop ;
-
-: >hexstring ( str -- hex )
- >array [ >hex 2 CHAR: 0 pad-left ] map concat ;
-
-: good-frame-id? ( id -- ? )
- [ [ LETTER? ] keep digit? or ] all? ;
-
-! 4 byte syncsafe integer (28 effective bits)
-: >syncsafe ( seq -- int )
- 0 [ >r 7 shift r> bitor ] reduce ;
-
-: read-size ( -- size )
- 4 read >syncsafe ;
-
-: read-frame-id ( -- id )
- 4 read ;
-
-: read-frame-flags ( -- flags )
- 2 read ;
-
-: read-frame-size ( -- size )
- 4 read be> ;
-
-: text-frame? ( id -- ? )
- "T" head? ;
-
-: read-text ( size -- text )
- read1 swap 1 - read swap 1 = [ decode-utf16 ] [ ] if
- "\0" ?tail drop ; ! remove null terminator
-
-: read-popm ( size -- popm )
- read-text ;
-
-: read-frame-data ( id size -- data )
- swap
- {
- { [ dup text-frame? ] [ drop read-text ] }
- { [ "POPM" = ] [ read-popm ] }
- { [ t ] [ read ] }
- } cond ;
-
-: (read-frame) ( id -- frame )
- read-frame-size read-frame-flags 2over read-frame-data <frame> ;
-
-: read-frame ( -- frame/f )
- read-frame-id dup good-frame-id? [ (read-frame) ] [ drop f ] if ;
-
-: (read-frames) ( vector -- frames )
- read-frame [ over push (read-frames) ] when* ;
-
-: read-frames ( -- frames )
- V{ } clone (read-frames) ;
-
-: read-eh-flags ( -- flags )
- read1 read le> ;
-
-: read-eh-data ( size -- data )
- 6 - read ;
-
-: read-crc ( flags -- crc )
- 5 bit? [ read1 read >syncsafe ] [ f ] if ;
-
-: tag-is-update? ( flags -- ? )
- 6 bit? dup [ read1 drop ] [ ] if ;
-
-: (read-tag-restrictions) ( -- restrictions )
- read1 dup read le> ;
-
-: read-tag-restrictions ( flags -- restrictions/f )
- 4 bit? [ (read-tag-restrictions) ] [ f ] if ;
-
-: (read-extended-header) ( -- extended-header )
- read-size read-eh-flags dup tag-is-update? over dup
- read-crc swap read-tag-restrictions <extended-header> ;
-
-: read-extended-header ( flags -- extended-header/f )
- 6 bit? [ (read-extended-header) ] [ f ] if ;
-
-: read-header ( version -- header )
- read1 read1 read-size over read-extended-header <header> ;
-
-: (read-id3v2) ( version -- tag )
- read-header read-frames <tag> ;
-
-: supported-version? ( version -- ? )
- { 3 4 } member? ;
-
-: read-id3v2 ( -- tag/f )
- read1 dup supported-version?
- [ (read-id3v2) ] [ drop f ] if ;
-
-: id3v2? ( -- ? )
- 3 read "ID3" sequence= ;
-
-: read-tag ( stream -- tag/f )
- id3v2? [ read-id3v2 ] [ f ] if ;
-
-: id3v2 ( filename -- tag/f )
- binary [ read-tag ] with-file-reader ;
-
-: file? ( path -- ? )
- stat 3drop not ;
-
-: files ( paths -- files )
- [ file? ] subset ;
-
-: mp3? ( path -- ? )
- ".mp3" tail? ;
-
-: mp3s ( paths -- mp3s )
- [ mp3? ] subset ;
-
-: id3? ( file -- ? )
- binary [ id3v2? ] with-file-reader ;
-
-: id3s ( files -- id3s )
- [ id3? ] subset ;
-
+++ /dev/null
-ID3 music file tag parser
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: alien.syntax ;
-
-IN: unix.linux.if
-
-: IFNAMSIZ 16 ;
-: IF_NAMESIZE 16 ;
-: IFHWADDRLEN 6 ;
-
-! Standard interface flags (netdevice->flags)
-
-: IFF_UP HEX: 1 ; ! interface is up
-: IFF_BROADCAST HEX: 2 ; ! broadcast address valid
-: IFF_DEBUG HEX: 4 ; ! turn on debugging
-: IFF_LOOPBACK HEX: 8 ; ! is a loopback net
-: IFF_POINTOPOINT HEX: 10 ; ! interface is has p-p link
-: IFF_NOTRAILERS HEX: 20 ; ! avoid use of trailers
-: IFF_RUNNING HEX: 40 ; ! interface running and carrier ok
-: IFF_NOARP HEX: 80 ; ! no ARP protocol
-: IFF_PROMISC HEX: 100 ; ! receive all packets
-: IFF_ALLMULTI HEX: 200 ; ! receive all multicast packets
-
-: IFF_MASTER HEX: 400 ; ! master of a load balancer
-: IFF_SLAVE HEX: 800 ; ! slave of a load balancer
-
-: IFF_MULTICAST HEX: 1000 ; ! Supports multicast
-
-! #define IFF_VOLATILE
-! (IFF_LOOPBACK|IFF_POINTOPOINT|IFF_BROADCAST|IFF_MASTER|IFF_SLAVE|IFF_RUNNING)
-
-: IFF_PORTSEL HEX: 2000 ; ! can set media type
-: IFF_AUTOMEDIA HEX: 4000 ; ! auto media select active
-: IFF_DYNAMIC HEX: 8000 ; ! dialup device with changing addresses
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-C-STRUCT: struct-ifmap
- { "ulong" "mem-start" }
- { "ulong" "mem-end" }
- { "ushort" "base-addr" }
- { "uchar" "irq" }
- { "uchar" "dma" }
- { "uchar" "port" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Hmm... the generic sockaddr type isn't defined anywhere.
-! Put it here for now.
-
-TYPEDEF: ushort sa_family_t
-
-C-STRUCT: struct-sockaddr
- { "sa_family_t" "sa_family" }
- { { "char" 14 } "sa_data" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! C-UNION: union-ifr-ifrn { "char" IFNAMSIZ } ;
-
-C-UNION: union-ifr-ifrn { "char" 16 } ;
-
-C-UNION: union-ifr-ifru
- "struct-sockaddr"
-! "sockaddr"
- "short"
- "int"
- "struct-ifmap"
-! { "char" IFNAMSIZ }
- { "char" 16 }
- "caddr_t" ;
-
-C-STRUCT: struct-ifreq
- { "union-ifr-ifrn" "ifr-ifrn" }
- { "union-ifr-ifru" "ifr-ifru" } ;
-
-: ifr-name ( struct-ifreq -- value ) struct-ifreq-ifr-ifrn ;
-
-: ifr-hwaddr ( struct-ifreq -- value ) struct-ifreq-ifr-ifru ;
-: ifr-addr ( struct-ifreq -- value ) struct-ifreq-ifr-ifru ;
-: ifr-dstaddr ( struct-ifreq -- value ) struct-ifreq-ifr-ifru ;
-: ifr-broadaddr ( struct-ifreq -- value ) struct-ifreq-ifr-ifru ;
-: ifr-netmask ( struct-ifreq -- value ) struct-ifreq-ifr-ifru ;
-: ifr-flags ( struct-ifreq -- value ) struct-ifreq-ifr-ifru ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-C-UNION: union-ifc-ifcu "caddr_t" "struct-ifreq*" ;
-
-C-STRUCT: struct-ifconf
- { "int" "ifc-len" }
- { "union-ifc-ifcu" "ifc-ifcu" } ;
-
-: ifc-len ( struct-ifconf -- value ) struct-ifconf-ifc-len ;
-
-: ifc-buf ( struct-ifconf -- value ) struct-ifconf-ifc-ifcu ;
-: ifc-req ( struct-ifconf -- value ) struct-ifconf-ifc-ifcu ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
\ No newline at end of file
+++ /dev/null
-unportable
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel alien alien.c-types
- io.sockets
- unix
- unix.linux.sockios
- unix.linux.if ;
-
-IN: unix.linux.ifreq
-
-: set-if-addr ( name addr -- )
- "struct-ifreq" <c-object>
- rot ascii string>alien over set-struct-ifreq-ifr-ifrn
- swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
-
- AF_INET SOCK_DGRAM 0 socket SIOCSIFADDR rot ioctl drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set-if-flags ( name flags -- )
- "struct-ifreq" <c-object>
- rot ascii string>alien over set-struct-ifreq-ifr-ifrn
- swap <short> over set-struct-ifreq-ifr-ifru
-
- AF_INET SOCK_DGRAM 0 socket SIOCSIFFLAGS rot ioctl drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set-if-dst-addr ( name addr -- )
- "struct-ifreq" <c-object>
- rot ascii string>alien over set-struct-ifreq-ifr-ifrn
- swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
-
- AF_INET SOCK_DGRAM 0 socket SIOCSIFDSTADDR rot ioctl drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set-if-brd-addr ( name addr -- )
- "struct-ifreq" <c-object>
- rot ascii string>alien over set-struct-ifreq-ifr-ifrn
- swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
-
- AF_INET SOCK_DGRAM 0 socket SIOCSIFBRDADDR rot ioctl drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set-if-netmask ( name addr -- )
- "struct-ifreq" <c-object>
- rot ascii string>alien over set-struct-ifreq-ifr-ifrn
- swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
-
- AF_INET SOCK_DGRAM 0 socket SIOCSIFNETMASK rot ioctl drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set-if-metric ( name metric -- )
- "struct-ifreq" <c-object>
- rot ascii string>alien over set-struct-ifreq-ifr-ifrn
- swap <int> over set-struct-ifreq-ifr-ifru
-
- AF_INET SOCK_DGRAM 0 socket SIOCSIFMETRIC rot ioctl drop ;
\ No newline at end of file
+++ /dev/null
-unportable
+++ /dev/null
-Alex Chapman
+++ /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 "Jamshred" }
-}
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ;
-IN: jamshred.game
-
-TUPLE: jamshred sounds tunnel players running quit ;
-
-: <jamshred> ( -- jamshred )
- <sounds> <random-tunnel> "Player 1" pick <player>
- 2dup swap play-in-tunnel 1array f f jamshred boa ;
-
-: jamshred-player ( jamshred -- player )
- ! TODO: support more than one player
- players>> first ;
-
-: jamshred-update ( jamshred -- )
- dup running>> [
- jamshred-player update-player
- ] [ drop ] if ;
-
-: toggle-running ( jamshred -- )
- dup running>> [
- f >>running drop
- ] [
- [ jamshred-player moved ]
- [ t >>running drop ] bi
- ] if ;
-
-: mouse-moved ( x-radians y-radians jamshred -- )
- jamshred-player -rot turn-player ;
-
-: units-per-full-roll ( -- n ) 50 ;
-
-: jamshred-roll ( jamshred n -- )
- [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;
-
-: mouse-scroll-x ( jamshred x -- ) jamshred-roll ;
-
-: mouse-scroll-y ( jamshred y -- )
- neg swap jamshred-player change-player-speed ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types jamshred.game jamshred.oint
-jamshred.player jamshred.tunnel kernel math math.constants
-math.functions math.vectors opengl opengl.gl opengl.glu
-opengl.demo-support sequences specialized-arrays.float ;
-IN: jamshred.gl
-
-: min-vertices 6 ; inline
-: max-vertices 32 ; inline
-
-: n-vertices ( -- n ) 32 ; inline
-
-! render enough of the tunnel that it looks continuous
-: n-segments-ahead ( -- n ) 60 ; inline
-: n-segments-behind ( -- n ) 40 ; inline
-
-: wall-drawing-offset ( -- n )
- #! so that we can't see through the wall, we draw it a bit further away
- 0.15 ;
-
-: wall-drawing-radius ( segment -- r )
- radius>> wall-drawing-offset + ;
-
-: wall-up ( segment -- v )
- [ wall-drawing-radius ] [ up>> ] bi n*v ;
-
-: wall-left ( segment -- v )
- [ wall-drawing-radius ] [ left>> ] bi n*v ;
-
-: segment-vertex ( theta segment -- vertex )
- [
- [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+
- ] [
- location>> v+
- ] bi ;
-
-: segment-vertex-normal ( vertex segment -- normal )
- location>> swap v- normalize ;
-
-: segment-vertex-and-normal ( segment theta -- vertex normal )
- swap [ segment-vertex ] keep dupd segment-vertex-normal ;
-
-: equally-spaced-radians ( n -- seq )
- #! return a sequence of n numbers between 0 and 2pi
- dup [ / pi 2 * * ] curry map ;
-
-: draw-segment-vertex ( segment theta -- )
- over color>> gl-color segment-vertex-and-normal
- gl-normal gl-vertex ;
-
-: draw-vertex-pair ( theta next-segment segment -- )
- rot tuck draw-segment-vertex draw-segment-vertex ;
-
-: draw-segment ( next-segment segment -- )
- GL_QUAD_STRIP [
- [ draw-vertex-pair ] 2curry
- n-vertices equally-spaced-radians F{ 0.0 } append swap each
- ] do-state ;
-
-: draw-segments ( segments -- )
- 1 over length pick subseq swap [ draw-segment ] 2each ;
-
-: segments-to-render ( player -- segments )
- dup nearest-segment>> number>> dup n-segments-behind -
- swap n-segments-ahead + rot tunnel>> sub-tunnel ;
-
-: draw-tunnel ( player -- )
- segments-to-render draw-segments ;
-
-: init-graphics ( width height -- )
- GL_DEPTH_TEST glEnable
- GL_SCISSOR_TEST glDisable
- 1.0 glClearDepth
- 0.0 0.0 0.0 0.0 glClearColor
- GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
- GL_PROJECTION glMatrixMode glLoadIdentity
- dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if
- GL_MODELVIEW glMatrixMode glLoadIdentity
- GL_LEQUAL glDepthFunc
- GL_LIGHTING glEnable
- GL_LIGHT0 glEnable
- GL_FOG glEnable
- GL_FOG_DENSITY 0.09 glFogf
- GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
- GL_COLOR_MATERIAL glEnable
- GL_LIGHT0 GL_POSITION float-array{ 0.0 0.0 0.0 1.0 } underlying>> glLightfv
- GL_LIGHT0 GL_AMBIENT float-array{ 0.2 0.2 0.2 1.0 } underlying>> glLightfv
- GL_LIGHT0 GL_DIFFUSE float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv
- GL_LIGHT0 GL_SPECULAR float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv ;
-
-: player-view ( player -- )
- [ location>> ]
- [ [ location>> ] [ forward>> ] bi v+ ]
- [ up>> ] tri gl-look-at ;
-
-: draw-jamshred ( jamshred width height -- )
- init-graphics jamshred-player [ player-view ] [ draw-tunnel ] bi ;
-
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.geometry.rect math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ;
-IN: jamshred
-
-TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ;
-
-: <jamshred-gadget> ( jamshred -- gadget )
- jamshred-gadget new-gadget swap >>jamshred ;
-
-: default-width ( -- x ) 800 ;
-: default-height ( -- y ) 600 ;
-
-M: jamshred-gadget pref-dim*
- drop default-width default-height 2array ;
-
-M: jamshred-gadget draw-gadget* ( gadget -- )
- [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ;
-
-: jamshred-loop ( gadget -- )
- dup jamshred>> quit>> [
- drop
- ] [
- [ jamshred>> jamshred-update ]
- [ relayout-1 ]
- [ 10 milliseconds sleep yield jamshred-loop ] tri
- ] if ;
-
-: fullscreen ( gadget -- )
- find-world t swap set-fullscreen* ;
-
-: no-fullscreen ( gadget -- )
- find-world f swap set-fullscreen* ;
-
-: toggle-fullscreen ( world -- )
- [ fullscreen? not ] keep set-fullscreen* ;
-
-M: jamshred-gadget graft* ( gadget -- )
- [ jamshred-loop ] curry in-thread ;
-
-M: jamshred-gadget ungraft* ( gadget -- )
- jamshred>> t swap (>>quit) ;
-
-: jamshred-restart ( jamshred-gadget -- )
- <jamshred> >>jamshred drop ;
-
-: pix>radians ( n m -- theta )
- / pi 4 * * ; ! 2 / / pi 2 * * ;
-
-: x>radians ( x gadget -- theta )
- #! translate motion of x pixels to an angle
- rect-dim first pix>radians neg ;
-
-: y>radians ( y gadget -- theta )
- #! translate motion of y pixels to an angle
- rect-dim second pix>radians ;
-
-: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
- over jamshred>> >r
- [ first swap x>radians ] 2keep second swap y>radians
- r> mouse-moved ;
-
-: handle-mouse-motion ( jamshred-gadget -- )
- hand-loc get [
- over last-hand-loc>> [
- v- (handle-mouse-motion)
- ] [ 2drop ] if*
- ] 2keep >>last-hand-loc drop ;
-
-: handle-mouse-scroll ( jamshred-gadget -- )
- jamshred>> scroll-direction get
- [ first mouse-scroll-x ]
- [ second mouse-scroll-y ] 2bi ;
-
-: quit ( gadget -- )
- [ no-fullscreen ] [ close-window ] bi ;
-
-jamshred-gadget H{
- { T{ key-down f f "r" } [ jamshred-restart ] }
- { T{ key-down f f " " } [ jamshred>> toggle-running ] }
- { T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
- { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] }
- { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] }
- { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] }
- { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] }
- { T{ key-down f f "q" } [ quit ] }
- { T{ motion } [ handle-mouse-motion ] }
- { T{ mouse-scroll } [ handle-mouse-scroll ] }
-} set-gestures
-
-: jamshred-window ( -- gadget )
- [ <jamshred> <jamshred-gadget> dup "Jamshred" open-window ] with-ui ;
-
-MAIN: jamshred-window
+++ /dev/null
-USING: kernel logging ;
-IN: jamshred.log
-
-LOG: (jamshred-log) DEBUG
-
-: with-jamshred-log ( quot -- )
- "jamshred" swap with-logging ;
-
-: jamshred-log ( message -- )
- [ (jamshred-log) ] with-jamshred-log ; ! ugly...
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: jamshred.oint tools.test ;
-IN: jamshred.oint-tests
-
-[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
-[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
-[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
-[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
-[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
-IN: jamshred.oint
-
-! An oint is a point with three linearly independent unit vectors
-! given relative to that point. In jamshred a player's location and
-! direction are given by the player's oint. Similarly, a tunnel
-! segment's location and orientation are given by an oint.
-
-TUPLE: oint location forward up left ;
-C: <oint> oint
-
-: rotation-quaternion ( theta axis -- quaternion )
- swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
-
-: rotate-vector ( q qrecip v -- v )
- v>q swap q* q* q>v ;
-
-: rotate-oint ( oint theta axis -- )
- rotation-quaternion dup qrecip pick
- [ forward>> rotate-vector >>forward ]
- [ up>> rotate-vector >>up ]
- [ left>> rotate-vector >>left ] 3tri drop ;
-
-: left-pivot ( oint theta -- )
- over left>> rotate-oint ;
-
-: up-pivot ( oint theta -- )
- over up>> rotate-oint ;
-
-: forward-pivot ( oint theta -- )
- over forward>> rotate-oint ;
-
-: random-float+- ( n -- m )
- #! find a random float between -n/2 and n/2
- dup 10000 * >fixnum random 10000 / swap 2 / - ;
-
-: random-turn ( oint theta -- )
- 2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
-
-: location+ ( v oint -- )
- [ location>> v+ ] [ (>>location) ] bi ;
-
-: go-forward ( distance oint -- )
- [ forward>> n*v ] [ location+ ] bi ;
-
-: distance-vector ( oint oint -- vector )
- [ location>> ] bi@ swap v- ;
-
-: distance ( oint oint -- distance )
- distance-vector norm ;
-
-: scalar-projection ( v1 v2 -- n )
- #! the scalar projection of v1 onto v2
- tuck v. swap norm / ;
-
-: proj-perp ( u v -- w )
- dupd proj v- ;
-
-: perpendicular-distance ( oint oint -- distance )
- tuck distance-vector swap 2dup left>> scalar-projection abs
- -rot up>> scalar-projection abs + ;
-
-:: reflect ( v n -- v' )
- #! bounce v on a surface with normal n
- v v n v. n n v. / 2 * n n*v v- ;
-
-: half-way ( p1 p2 -- p3 )
- over v- 2 v/n v+ ;
-
-: half-way-between-oints ( o1 o2 -- p )
- [ location>> ] bi@ half-way ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors combinators float-arrays jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle strings system ;
-IN: jamshred.player
-
-TUPLE: player < oint
- { name string }
- { sounds sounds }
- tunnel
- nearest-segment
- { last-move integer }
- { speed float } ;
-
-! speeds are in GL units / second
-: default-speed ( -- speed ) 1.0 ;
-: max-speed ( -- speed ) 30.0 ;
-
-: <player> ( name sounds -- player )
- [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip
- f f 0 default-speed player boa ;
-
-: turn-player ( player x-radians y-radians -- )
- >r over r> left-pivot up-pivot ;
-
-: roll-player ( player z-radians -- )
- forward-pivot ;
-
-: to-tunnel-start ( player -- )
- [ tunnel>> first dup location>> ]
- [ tuck (>>location) (>>nearest-segment) ] bi ;
-
-: play-in-tunnel ( player segments -- )
- >>tunnel to-tunnel-start ;
-
-: update-nearest-segment ( player -- )
- [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
- [ (>>nearest-segment) ] tri ;
-
-: update-time ( player -- seconds-passed )
- millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
-
-: moved ( player -- ) millis swap (>>last-move) ;
-
-: speed-range ( -- range )
- max-speed [0,b] ;
-
-: change-player-speed ( inc player -- )
- [ + speed-range clamp-to-range ] change-speed drop ;
-
-: multiply-player-speed ( n player -- )
- [ * speed-range clamp-to-range ] change-speed drop ;
-
-: distance-to-move ( seconds-passed player -- distance )
- speed>> * ;
-
-: bounce ( d-left player -- d-left' player )
- {
- [ dup nearest-segment>> bounce-off-wall ]
- [ sounds>> bang ]
- [ 3/4 swap multiply-player-speed ]
- [ ]
- } cleave ;
-
-:: (distance) ( heading player -- current next location heading )
- player nearest-segment>>
- player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
- player location>> heading ;
-
-: distance-to-heading-segment ( heading player -- distance )
- (distance) distance-to-next-segment ;
-
-: distance-to-heading-segment-area ( heading player -- distance )
- (distance) distance-to-next-segment-area ;
-
-: distance-to-collision ( player -- distance )
- dup nearest-segment>> (distance-to-collision) ;
-
-: almost-to-collision ( player -- distance )
- distance-to-collision 0.1 - dup 0 < [ drop 0 ] when ;
-
-: from ( player -- radius distance-from-centre )
- [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
- distance-from-centre ;
-
-: distance-from-wall ( player -- distance ) from - ;
-: fraction-from-centre ( player -- fraction ) from swap / ;
-: fraction-from-wall ( player -- fraction )
- fraction-from-centre 1 swap - ;
-
-: update-nearest-segment2 ( heading player -- )
- 2dup distance-to-heading-segment-area 0 <= [
- [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
- [ (>>nearest-segment) ] tri
- ] [
- 2drop
- ] if ;
-
-:: move-player-on-heading ( d-left player distance heading -- d-left' player )
- [let* | d-to-move [ d-left distance min ]
- move-v [ d-to-move heading n*v ] |
- move-v player location+
- heading player update-nearest-segment2
- d-left d-to-move - player ] ;
-
-: distance-to-move-freely ( player -- distance )
- [ almost-to-collision ]
- [ [ forward>> ] keep distance-to-heading-segment-area ] bi min ;
-
-: ?move-player-freely ( d-left player -- d-left' player )
- over 0 > [
- ! must make sure we are moving a significant distance, otherwise
- ! we can recurse endlessly due to floating-point imprecision.
- ! (at least I /think/ that's what causes it...)
- dup distance-to-move-freely dup 0.1 > [
- over forward>> move-player-on-heading ?move-player-freely
- ] [ drop ] if
- ] when ;
-
-: drag-heading ( player -- heading )
- [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
-
-: drag-player ( d-left player -- d-left' player )
- dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
- [ drag-heading move-player-on-heading ] bi ;
-
-: (move-player) ( d-left player -- d-left' player )
- ?move-player-freely over 0 > [
- ! bounce
- drag-player
- (move-player)
- ] when ;
-
-: move-player ( player -- )
- [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
-
-: update-player ( player -- )
- [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ;
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io.files kernel openal sequences ;
-IN: jamshred.sound
-
-TUPLE: sounds bang ;
-
-: assign-sound ( source wav-path -- )
- resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ;
-
-: <sounds> ( -- sounds )
- init-openal 1 gen-sources first sounds boa
- dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ;
-
-: bang ( sounds -- ) bang>> source-play check-error ;
+++ /dev/null
-A simple 3d tunnel racing game
+++ /dev/null
-applications
-games
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays float-arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences tools.test ;
-IN: jamshred.tunnel.tests
-
-[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
- T{ segment f { 1 1 1 } f f f 1 }
- T{ oint f { 0 0 0.25 } }
- nearer-segment number>> ] unit-test
-
-[ 0 ] [ T{ oint f { 0 0 0 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
-[ 1 ] [ T{ oint f { 0 0 -1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
-[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
-
-[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test
-
-[ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test
-
-: test-segment-oint ( -- oint )
- { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
-
-[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
-[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
-[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
-[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
-[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
-[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
-[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
-[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
-
-: simplest-straight-ahead ( -- oint segment )
- { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
- initial-segment ;
-
-[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
-[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
-
-: simple-collision-up ( -- oint segment )
- { 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } <oint>
- initial-segment ;
-
-[ { 0.0 1.0 0.0 } ] [ simple-collision-up sideways-heading ] unit-test
-[ { 0.0 0.0 0.0 } ] [ simple-collision-up sideways-relative-location ] unit-test
-[ { 0.0 1.0 0.0 } ]
-[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays colors combinators float-arrays kernel
-locals math math.constants math.matrices math.order math.ranges
-math.vectors math.quadratic random sequences vectors jamshred.oint ;
-IN: jamshred.tunnel
-
-: n-segments ( -- n ) 5000 ; inline
-
-TUPLE: segment < oint number color radius ;
-C: <segment> segment
-
-: segment-number++ ( segment -- )
- [ number>> 1+ ] keep (>>number) ;
-
-: random-color ( -- color )
- { 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
-
-: tunnel-segment-distance ( -- n ) 0.4 ;
-: random-rotation-angle ( -- theta ) pi 20 / ;
-
-: random-segment ( previous-segment -- segment )
- clone dup random-rotation-angle random-turn
- tunnel-segment-distance over go-forward
- random-color >>color dup segment-number++ ;
-
-: (random-segments) ( segments n -- segments )
- dup 0 > [
- >r dup peek random-segment over push r> 1- (random-segments)
- ] [ drop ] if ;
-
-: default-segment-radius ( -- r ) 1 ;
-
-: initial-segment ( -- segment )
- F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
- 0 random-color default-segment-radius <segment> ;
-
-: random-segments ( n -- segments )
- initial-segment 1vector swap (random-segments) ;
-
-: simple-segment ( n -- segment )
- [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
- random-color default-segment-radius <segment> ;
-
-: simple-segments ( n -- segments )
- [ simple-segment ] map ;
-
-: <random-tunnel> ( -- segments )
- n-segments random-segments ;
-
-: <straight-tunnel> ( -- segments )
- n-segments simple-segments ;
-
-: sub-tunnel ( from to segments -- segments )
- #! return segments between from and to, after clamping from and to to
- #! valid values
- [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
-
-: nearer-segment ( segment segment oint -- segment )
- #! return whichever of the two segments is nearer to the oint
- >r 2dup r> tuck distance >r distance r> < -rot ? ;
-
-: (find-nearest-segment) ( nearest next oint -- nearest ? )
- #! find the nearest of 'next' and 'nearest' to 'oint', and return
- #! t if the nearest hasn't changed
- pick >r nearer-segment dup r> = ;
-
-: find-nearest-segment ( oint segments -- segment )
- dup first swap rest-slice rot [ (find-nearest-segment) ] curry
- find 2drop ;
-
-: nearest-segment-forward ( segments oint start -- segment )
- rot dup length swap <slice> find-nearest-segment ;
-
-: nearest-segment-backward ( segments oint start -- segment )
- swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
-
-: nearest-segment ( segments oint start-segment -- segment )
- #! find the segment nearest to 'oint', and return it.
- #! start looking at segment 'start-segment'
- number>> over >r
- [ nearest-segment-forward ] 3keep
- nearest-segment-backward r> nearer-segment ;
-
-: get-segment ( segments n -- segment )
- over sequence-index-range clamp-to-range swap nth ;
-
-: next-segment ( segments current-segment -- segment )
- number>> 1+ get-segment ;
-
-: previous-segment ( segments current-segment -- segment )
- number>> 1- get-segment ;
-
-: heading-segment ( segments current-segment heading -- segment )
- #! the next segment on the given heading
- over forward>> v. 0 <=> {
- { +gt+ [ next-segment ] }
- { +lt+ [ previous-segment ] }
- { +eq+ [ nip ] } ! current segment
- } case ;
-
-:: distance-to-next-segment ( current next location heading -- distance )
- [let | cf [ current forward>> ] |
- cf next location>> v. cf location v. - cf heading v. / ] ;
-
-:: distance-to-next-segment-area ( current next location heading -- distance )
- [let | cf [ current forward>> ]
- h [ next current half-way-between-oints ] |
- cf h v. cf location v. - cf heading v. / ] ;
-
-: vector-to-centre ( seg loc -- v )
- over location>> swap v- swap forward>> proj-perp ;
-
-: distance-from-centre ( seg loc -- distance )
- vector-to-centre norm ;
-
-: wall-normal ( seg oint -- n )
- location>> vector-to-centre normalize ;
-
-: distant ( -- n ) 1000 ;
-
-: max-real ( a b -- c )
- #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
- dup real? [
- over real? [ max ] [ nip ] if
- ] [
- drop dup real? [ drop distant ] unless
- ] if ;
-
-:: collision-coefficient ( v w r -- c )
- v norm 0 = [
- distant
- ] [
- [let* | a [ v dup v. ]
- b [ v w v. 2 * ]
- c [ w dup v. r sq - ] |
- c b a quadratic max-real ]
- ] if ;
-
-: sideways-heading ( oint segment -- v )
- [ forward>> ] bi@ proj-perp ;
-
-: sideways-relative-location ( oint segment -- loc )
- [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
-
-: (distance-to-collision) ( oint segment -- distance )
- [ sideways-heading ] [ sideways-relative-location ]
- [ nip radius>> ] 2tri collision-coefficient ;
-
-: collision-vector ( oint segment -- v )
- dupd (distance-to-collision) swap forward>> n*v ;
-
-: bounce-forward ( segment oint -- )
- [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
-
-: bounce-left ( segment oint -- )
- #! must be done after forward
- [ forward>> vneg ] dip [ left>> swap reflect ]
- [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
-
-: bounce-up ( segment oint -- )
- #! must be done after forward and left!
- nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
-
-: bounce-off-wall ( oint segment -- )
- swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
-
+++ /dev/null
-James Cash
+++ /dev/null
-IN: lisp
-USING: help.markup help.syntax ;
-HELP: <LISP
-{ $description "parsing word which converts the lisp code between <LISP and LISP> into factor quotations and calls it" }
-{ $see-also lisp-string>factor } ;
-
-HELP: lisp-string>factor
-{ $values { "str" "a string of lisp code" } { "quot" "the quotation the lisp compiles into" } }
-{ $description "Turns a string of lisp into a factor quotation" } ;
-
-ARTICLE: "lisp" "Lisp in Factor"
-"This is a simple implementation of a Lisp dialect, which somewhat resembles Scheme." $nl
-"It works in two main stages: "
-{ $list
- { "Parse (via " { $vocab-link "lisp.parser" } " the Lisp code into a "
- { $snippet "s-exp" } " tuple." }
- { "Transform the " { $snippet "s-exp" } " into a Factor quotation, via " { $link convert-form } }
-}
-
-{ $subsection "lisp.parser" } ;
-
-ABOUT: "lisp"
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 James Cash
-! See http://factorcode.org/license.txt for BSD license.
-USING: lisp lisp.parser tools.test sequences math kernel parser arrays lists
-quotations ;
-
-IN: lisp.test
-
-[
- define-lisp-builtins
-
- { 5 } [
- "(+ 2 3)" lisp-eval
- ] unit-test
-
- { 8.3 } [
- "(- 10.4 2.1)" lisp-eval
- ] unit-test
-
- { 3 } [
- "((lambda (x y) (+ x y)) 1 2)" lisp-eval
- ] unit-test
-
- { 42 } [
- "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval
- ] unit-test
-
- { "b" } [
- "(cond (#f \"a\") (#t \"b\"))" lisp-eval
- ] unit-test
-
- { "b" } [
- "(cond ((< 1 2) \"b\") (#t \"a\"))" lisp-eval
- ] unit-test
-
- { +nil+ } [
- "(list)" lisp-eval
- ] unit-test
-
- { { 1 2 3 4 5 } } [
- "(list 1 2 3 4 5)" lisp-eval list>seq
- ] unit-test
-
- { { 1 2 { 3 { 4 } 5 } } } [
- "(list 1 2 (list 3 (list 4) 5))" lisp-eval cons>seq
- ] unit-test
-
- { 5 } [
- "(begin (+ 1 4))" lisp-eval
- ] unit-test
-
- { 5 } [
- "(begin (+ 5 6) (+ 1 4))" lisp-eval
- ] unit-test
-
- { t } [
- T{ lisp-symbol f "if" } lisp-macro?
- ] unit-test
-
- { 1 } [
- "(if #t 1 2)" lisp-eval
- ] unit-test
-
- { 3 } [
- "((lambda (x) (if x (+ 1 2) (- 3 5))) #t)" lisp-eval
- ] unit-test
-
- { { 5 4 3 } } [
- "((lambda (x &rest xs) (cons x xs)) 5 4 3)" lisp-eval cons>seq
- ] unit-test
-
- { { 5 } } [
- "((lambda (x &rest xs) (cons x xs)) 5)" lisp-eval cons>seq
- ] unit-test
-
- { { 1 2 3 4 } } [
- "((lambda (&rest xs) xs) 1 2 3 4)" lisp-eval cons>seq
- ] unit-test
-
- { 10 } [
- <LISP (begin (+ 1 2) (+ 9 1)) LISP>
- ] unit-test
-
- { 4 } [
- <LISP ((lambda (x y) (if x (+ 1 y) (+ 2 y))) #t 3) LISP>
- ] unit-test
-
- { { 3 3 4 } } [
- <LISP (defun foo (x y &rest z)
- (cons (+ x y) z))
- (foo 1 2 3 4)
- LISP> cons>seq
- ] unit-test
-
-] with-interactive-vocabs
+++ /dev/null
-! Copyright (C) 2008 James Cash
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg sequences arrays strings
-namespaces combinators math locals locals.private locals.backend accessors
-vectors syntax lisp.parser assocs parser words
-quotations fry lists summary combinators.short-circuit continuations multiline ;
-IN: lisp
-
-DEFER: convert-form
-DEFER: funcall
-DEFER: lookup-var
-DEFER: lookup-macro
-DEFER: lisp-macro?
-DEFER: lisp-var?
-DEFER: define-lisp-macro
-
-! Functions to convert s-exps to quotations
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: convert-body ( cons -- quot )
- [ ] [ convert-form compose ] foldl ; inline
-
-: convert-cond ( cons -- quot )
- cdr [ 2car [ convert-form ] bi@ 2array ]
- { } lmap-as '[ _ cond ] ;
-
-: convert-general-form ( cons -- quot )
- uncons [ convert-body ] [ convert-form ] bi* '[ _ @ funcall ] ;
-
-! words for convert-lambda
-<PRIVATE
-: localize-body ( assoc body -- newbody )
- {
- { [ dup list? ] [ [ lisp-symbol? ] rot '[ [ name>> _ at ] [ ] bi or ] traverse ] }
- { [ dup lisp-symbol? ] [ name>> swap at ] }
- [ nip ]
- } cond ;
-
-: localize-lambda ( body vars -- newvars newbody )
- swap [ make-locals dup push-locals ] dip
- dupd [ localize-body convert-form ] with lmap>array
- >quotation swap pop-locals ;
-
-: split-lambda ( cons -- body-cons vars-seq )
- cdr uncons [ name>> ] lmap>array ; inline
-
-: rest-lambda ( body vars -- quot )
- "&rest" swap [ remove ] [ index ] 2bi
- [ localize-lambda <lambda> lambda-rewrite call ] dip
- swap '[ _ cut '[ @ _ seq>list ] call _ call call ] 1quotation ;
-
-: normal-lambda ( body vars -- quot )
- localize-lambda <lambda> lambda-rewrite '[ @ compose call call ] 1quotation ;
-PRIVATE>
-
-: convert-lambda ( cons -- quot )
- split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ;
-
-: convert-quoted ( cons -- quot )
- cadr 1quotation ;
-
-: convert-defmacro ( cons -- quot )
- cdr [ convert-lambda ] [ car name>> ] bi define-lisp-macro [ ] ;
-
-: macro-expand ( cons -- quot )
- uncons [ list>seq >quotation ] [ lookup-macro ] bi* call call ;
-
-: expand-macros ( cons -- cons )
- dup list? [ [ expand-macros ] lmap dup car lisp-macro? [ macro-expand expand-macros ] when ] when ;
-
-: convert-begin ( cons -- quot )
- cdr [ convert-form ] [ ] lmap-as [ 1 tail* ] [ but-last ] bi
- [ '[ { } _ with-datastack drop ] ] map prepend '[ _ [ call ] each ] ;
-
-: form-dispatch ( cons lisp-symbol -- quot )
- name>>
- { { "lambda" [ convert-lambda ] }
- { "defmacro" [ convert-defmacro ] }
- { "quote" [ convert-quoted ] }
- { "cond" [ convert-cond ] }
- { "begin" [ convert-begin ] }
- [ drop convert-general-form ]
- } case ;
-
-: convert-list-form ( cons -- quot )
- dup car
- {
- { [ dup lisp-symbol? ] [ form-dispatch ] }
- [ drop convert-general-form ]
- } cond ;
-
-: convert-form ( lisp-form -- quot )
- {
- { [ dup cons? ] [ convert-list-form ] }
- { [ dup lisp-var? ] [ lookup-var 1quotation ] }
- { [ dup lisp-symbol? ] [ '[ _ lookup-var ] ] }
- [ 1quotation ]
- } cond ;
-
-: lisp-string>factor ( str -- quot )
- lisp-expr expand-macros convert-form ;
-
-: lisp-eval ( str -- * )
- lisp-string>factor call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: lisp-env
-SYMBOL: macro-env
-
-ERROR: no-such-var variable-name ;
-M: no-such-var summary drop "No such variable" ;
-
-: init-env ( -- )
- H{ } clone lisp-env set
- H{ } clone macro-env set ;
-
-: lisp-define ( quot name -- )
- lisp-env get set-at ;
-
-: define-lisp-var ( lisp-symbol body -- )
- swap name>> lisp-define ;
-
-: lisp-get ( name -- word )
- lisp-env get at ;
-
-: lookup-var ( lisp-symbol -- quot )
- [ name>> ] [ lisp-var? ] bi [ lisp-get ] [ no-such-var ] if ;
-
-: lisp-var? ( lisp-symbol -- ? )
- dup lisp-symbol? [ name>> lisp-env get key? ] [ drop f ] if ;
-
-: funcall ( quot sym -- * )
- [ 1array [ call ] with-datastack >quotation ] dip curry call ; inline
-
-: define-primitive ( name vocab word -- )
- swap lookup 1quotation '[ _ compose call ] swap lisp-define ;
-
-: lookup-macro ( lisp-symbol -- lambda )
- name>> macro-env get at ;
-
-: define-lisp-macro ( quot name -- )
- macro-env get set-at ;
-
-: lisp-macro? ( car -- ? )
- dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ;
-
-: define-lisp-builtins ( -- )
- init-env
-
- f "#f" lisp-define
- t "#t" lisp-define
-
- "+" "math" "+" define-primitive
- "-" "math" "-" define-primitive
- "<" "math" "<" define-primitive
- ">" "math" ">" define-primitive
-
- "cons" "lists" "cons" define-primitive
- "car" "lists" "car" define-primitive
- "cdr" "lists" "cdr" define-primitive
- "append" "lists" "lappend" define-primitive
- "nil" "lists" "nil" define-primitive
- "nil?" "lists" "nil?" define-primitive
-
- "set" "lisp" "define-lisp-var" define-primitive
-
- "(set 'list (lambda (&rest xs) xs))" lisp-eval
- "(defmacro setq (var val) (list 'set (list 'quote var) val))" lisp-eval
-
- <" (defmacro defun (name vars &rest body)
- (list 'setq name (cons 'lambda (cons vars body)))) "> lisp-eval
-
- "(defmacro if (pred tr fl) (list 'cond (list pred tr) (list (quote #t) fl)))" lisp-eval
- ;
-
-: <LISP
- "LISP>" parse-multiline-string "(begin " prepend ")" append define-lisp-builtins
- lisp-string>factor parsed \ call parsed ; parsing
\ No newline at end of file
+++ /dev/null
-James Cash
+++ /dev/null
-IN: lisp.parser
-USING: help.markup help.syntax ;
-
-ARTICLE: "lisp.parser" "Parsing strings of Lisp"
-"This vocab uses " { $vocab-link "peg.ebnf" } " to turn strings of Lisp into " { $snippet "s-exp" } "s, which are then used by"
-{ $vocab-link "lisp" } " to produce Factor quotations." ;
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 James Cash
-! See http://factorcode.org/license.txt for BSD license.
-USING: lisp.parser tools.test peg peg.ebnf lists ;
-
-IN: lisp.parser.tests
-
-{ 1234 } [
- "1234" "atom" \ lisp-expr rule parse
-] unit-test
-
-{ -42 } [
- "-42" "atom" \ lisp-expr rule parse
-] unit-test
-
-{ 37/52 } [
- "37/52" "atom" \ lisp-expr rule parse
-] unit-test
-
-{ 123.98 } [
- "123.98" "atom" \ lisp-expr rule parse
-] unit-test
-
-{ "" } [
- "\"\"" "atom" \ lisp-expr rule parse
-] unit-test
-
-{ "aoeu" } [
- "\"aoeu\"" "atom" \ lisp-expr rule parse
-] unit-test
-
-{ "aoeu\"de" } [
- "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse
-] unit-test
-
-{ T{ lisp-symbol f "foobar" } } [
- "foobar" "atom" \ lisp-expr rule parse
-] unit-test
-
-{ T{ lisp-symbol f "+" } } [
- "+" "atom" \ lisp-expr rule parse
-] unit-test
-
-{ +nil+ } [
- "()" lisp-expr
-] unit-test
-
-{ T{
- cons
- f
- T{ lisp-symbol f "foo" }
- T{
- cons
- f
- 1
- T{ cons f 2 T{ cons f "aoeu" +nil+ } }
- } } } [
- "(foo 1 2 \"aoeu\")" lisp-expr
-] unit-test
-
-{ T{ cons f
- 1
- T{ cons f
- T{ cons f 3 T{ cons f 4 +nil+ } }
- T{ cons f 2 +nil+ } }
- }
-} [
- "(1 (3 4) 2)" lisp-expr
-] unit-test
-
-{ { T{ lisp-symbol { name "quote" } } { 1 2 3 } } } [
- "'(1 2 3)" lisp-expr cons>seq
-] unit-test
-
-{ { T{ lisp-symbol f "quote" } T{ lisp-symbol f "foo" } } } [
- "'foo" lisp-expr cons>seq
-] unit-test
-
-{ { 1 2 { T{ lisp-symbol { name "quote" } } { 3 4 } } 5 } } [
- "(1 2 '(3 4) 5)" lisp-expr cons>seq
-] unit-test
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 James Cash
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg peg.ebnf math.parser sequences arrays strings
-math fry accessors lists combinators.short-circuit ;
-
-IN: lisp.parser
-
-TUPLE: lisp-symbol name ;
-C: <lisp-symbol> lisp-symbol
-
-EBNF: lisp-expr
-_ = (" " | "\t" | "\n")*
-LPAREN = "("
-RPAREN = ")"
-dquote = '"'
-squote = "'"
-digit = [0-9]
-integer = ("-")? (digit)+ => [[ first2 append string>number ]]
-float = integer "." (digit)* => [[ first3 >string [ number>string ] 2dip 3append string>number ]]
-rational = integer "/" (digit)+ => [[ first3 nip string>number / ]]
-number = float
- | rational
- | integer
-id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":"
- | "<" | "#" | " =" | ">" | "?" | "^" | "_"
- | "~" | "+" | "-" | "." | "@"
-letters = [a-zA-Z] => [[ 1array >string ]]
-initials = letters | id-specials
-numbers = [0-9] => [[ 1array >string ]]
-subsequents = initials | numbers
-identifier = initials (subsequents)* => [[ first2 concat append <lisp-symbol> ]]
-escaped = "\" . => [[ second ]]
-string = dquote ( escaped | !(dquote) . )* dquote => [[ second >string ]]
-atom = number
- | identifier
- | string
-s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
-list-item = _ ( atom | s-expression | quoted ) _ => [[ second ]]
-quoted = squote list-item => [[ second nil cons "quote" <lisp-symbol> swap cons ]]
-expr = list-item
-;EBNF
\ No newline at end of file
+++ /dev/null
-EBNF grammar for parsing Lisp
+++ /dev/null
-lisp
-parsing
+++ /dev/null
-A Lisp interpreter/compiler in Factor
+++ /dev/null
-lisp
-languages
+++ /dev/null
-! Copyright (C) 2007 Adam Wendt.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: alien alien.c-types byte-arrays io io.binary io.files kernel mad\r
- namespaces prettyprint sbufs sequences tools.interpreter vars\r
- io.encodings.binary ;\r
-IN: mad.api\r
-\r
-VARS: buffer-start buffer-length output-callback-var ;\r
-\r
-: create-mad-callback-generic ( sequence parameters -- alien )\r
- swap >r >r "mad_flow" r> "cdecl" r> alien-callback ; inline\r
-\r
-: create-input-callback ( sequence -- alien )\r
- { "void*" "mad_stream*" } create-mad-callback-generic ; inline\r
-\r
-: create-header-callback ( sequence -- alien )\r
- { "void*" "mad_header*" } create-mad-callback-generic ; inline\r
-\r
-: create-filter-callback ( sequence -- alien )\r
- { "void*" "mad_stream*" "mad_frame*" } create-mad-callback-generic ; inline\r
-\r
-: create-output-callback ( sequence -- alien )\r
- { "void*" "mad_header*" "mad_pcm*" } create-mad-callback-generic ; inline\r
-\r
-: create-error-callback ( sequence -- alien )\r
- { "void*" "mad_stream*" "mad_frame*" } create-mad-callback-generic ; inline\r
-\r
-: create-message-callback ( sequence -- alien )\r
- { "void*" "void*" "uint*" } create-mad-callback-generic ; inline\r
-\r
-: input ( buffer mad_stream -- mad_flow )\r
- "input" print flush\r
- nip ! mad_stream\r
- buffer-start get ! mad_stream start\r
- buffer-length get ! mad_stream start length\r
- dup 0 = ! mad-stream start length bool\r
- [ 3drop MAD_FLOW_STOP ] ! mad_flow\r
- [ mad_stream_buffer ! \r
- 0 buffer-length set ! \r
- MAD_FLOW_CONTINUE ] if ; ! mad_flow\r
-\r
-: input-callback ( -- callback )\r
- [ input ] create-input-callback ;\r
-\r
-: header-callback ( -- callback )\r
- [ "header" print flush drop drop MAD_FLOW_CONTINUE ] create-header-callback ;\r
-\r
-: filter-callback ( -- callback )\r
- [ "filter" print flush 3drop MAD_FLOW_CONTINUE ] create-filter-callback ;\r
-\r
-: write-sample ( sample -- )\r
- 4 >le write ;\r
-\r
-: output ( data header pcm -- mad_flow )\r
- "output" . flush\r
- -rot 2drop output-callback-var> call\r
- [ MAD_FLOW_CONTINUE ] [ MAD_FLOW_STOP ] if ;\r
-\r
-: output-stdout ( pcm -- ? )\r
- [ mad_pcm-channels ] keep\r
- [ mad_pcm-length ] keep swap\r
- [\r
- [ mad_pcm-sample-right ] 2keep\r
- [ mad_pcm-sample-left ] 2keep\r
- drop -rot write-sample pick\r
- 2 = [ write-sample ] [ drop ] if\r
- ] each drop t ;\r
-\r
-: output-callback ( -- callback )\r
- [ output ] create-output-callback ;\r
-\r
-: error-callback ( -- callback )\r
- [ "error" print flush drop drop drop MAD_FLOW_CONTINUE ] create-error-callback ;\r
-\r
-: message-callback ( -- callback )\r
- [ "message" print flush drop drop drop MAD_FLOW_CONTINUE ] create-message-callback ;\r
-\r
-: mad-init ( decoder -- )\r
- 0 <alien> input-callback 0 <alien> 0 <alien> output-callback error-callback message-callback mad_decoder_init ;\r
-\r
-: make-decoder ( -- decoder )\r
- "mad_decoder" malloc-object ;\r
-\r
-: mad-run ( -- int )\r
- make-decoder [ mad-init ] keep MAD_DECODER_MODE_SYNC mad_decoder_run ;\r
-\r
-: init-vars ( alien length -- )\r
- buffer-length set buffer-start set ;\r
-\r
-: decode-mp3 ( filename -- results )\r
- [ malloc-file-contents ] keep file-length init-vars mad-run ;\r
-\r
-: mad-test ( -- results )\r
- [ output-stdout ] >output-callback-var\r
- "/home/adam/download/mp3/Misc/wutbf.mp3" decode-mp3 ;\r
+++ /dev/null
-Adam Wendt
+++ /dev/null
-Adam Wendt
+++ /dev/null
-! Copyright (C) 2007 Adam Wendt.
-! See http://factorcode.org/license.txt for BSD license.
-!
-IN: temporary
-
-USING: kernel mad mad.api alien alien.c-types tools.test
-namespaces ;
-
-: setup-buffer ( -- )
- 0 <alien> buffer-start set 0 buffer-length set ;
-
-[ t ] [ 0 "mad_stream" malloc-object setup-buffer input MAD_FLOW_STOP = ] unit-test
+++ /dev/null
-! Copyright (C) 2007 Adam Wendt.
-! See http://factorcode.org/license.txt for BSD license.
-!
-USING: alien alien.c-types alien.syntax combinators kernel math system ;
-IN: mad
-
-<< "mad" {
- { [ macosx? ] [ "libmad.0.dylib" ] }
- { [ unix? ] [ "libmad.so" ] }
- { [ windows? ] [ "mad.dll" ] }
- } cond "cdecl" add-library >>
-
-LIBRARY: mad
-
-TYPEDEF: int mad_fixed_t
-TYPEDEF: int mad_fixed64hi_t
-TYPEDEF: uint mad_fixed64lo_t
-
-TYPEDEF: int mad_flow
-TYPEDEF: int mad_decoder_mode
-TYPEDEF: int mad_error
-TYPEDEF: int mad_layer
-TYPEDEF: int mad_mode
-TYPEDEF: int mad_emphasis
-
-C-STRUCT: mad_timer_t
- { "long" "seconds" }
- { "ulong" "fraction" }
-;
-
-C-STRUCT: mad_bitptr
- { "uchar*" "byte" }
- { "short" "cache" }
- { "short" "left" }
-;
-
-C-STRUCT: mad_stream
- { "uchar*" "buffer" }
- { "uchar*" "buffend" }
- { "long" "skiplen" }
- { "int" "sync" }
- { "ulong" "freerate" }
- { "uchar*" "this_frame" }
- { "uchar*" "next_frame" }
- { "mad_bitptr" "ptr" }
- { "mad_bitptr" "anc_ptr" }
- { "uchar*" "main_data" }
- { "int" "md_len" }
- { "int" "options" }
- { "mad_error" "error" }
-;
-
-C-STRUCT: struct_async
- { "long" "pid" }
- { "int" "in" }
- { "int" "out" }
-;
-
-C-STRUCT: mad_header
- { "mad_layer" "layer" }
- { "mad_mode" "mode" }
- { "int" "mode_extension" }
- { "mad_emphasis" "emphasis" }
- { "ulong" "bitrate" }
- { "uint" "samplerate" }
- { "ushort" "crc_check" }
- { "ushort" "crc_target" }
- { "int" "flags" }
- { "int" "private_bits" }
- { "mad_timer_t" "duration" }
-;
-
-C-STRUCT: mad_frame
- { "mad_header" "header" }
- { "int" "options" }
- { { "mad_fixed_t" 2304 } "sbsample" }
- { "mad_fixed_t*" "overlap" }
-;
-
-C-STRUCT: mad_pcm
- { "uint" "samplerate" }
- { "ushort" "channels" }
- { "ushort" "length" }
- { { "mad_fixed_t" 2304 } "samples" }
-;
-
-: mad_pcm-sample-left ( pcm int -- sample )
- swap mad_pcm-samples int-nth ;
-: mad_pcm-sample-right ( pcm int -- sample )
- 1152 + swap mad_pcm-samples int-nth ;
-
-C-STRUCT: mad_synth
- { { "mad_fixed_t" 1024 } "filter" }
- { "uint" "phase" }
- { "mad_pcm" "pcm" }
-;
-
-C-STRUCT: struct_sync
- { "mad_stream" "stream" }
- { "mad_frame" "frame" }
- { "mad_synth" "synth" }
-;
-
-C-STRUCT: mad_decoder
- { "mad_decoder_mode" "mode" }
- { "int" "options" }
- { "struct_async" "async" }
- { "struct_sync*" "sync" }
- { "void*" "cb_data" }
- { "void*" "input_func" }
- { "void*" "header_func" }
- { "void*" "filter_func" }
- { "void*" "output_func" }
- { "void*" "error_func" }
- { "void*" "message_func" }
-;
-
-: MAD_F_FRACBITS ( -- number ) 28 ; inline
-: MAD_F_ONE HEX: 10000000 ;
-
-: MAD_DECODER_MODE_SYNC ( -- number ) HEX: 0 ; inline
-: MAD_DECODER_MODE_ASYNC ( -- number ) HEX: 1 ; inline
-
-: MAD_FLOW_CONTINUE ( -- number ) HEX: 0 ; inline
-: MAD_FLOW_STOP ( -- number ) HEX: 10 ; inline
-: MAD_FLOW_BREAK ( -- number ) HEX: 11 ; inline
-: MAD_FLOW_IGNORE ( -- number ) HEX: 20 ; inline
-
-: MAD_ERROR_NONE ( -- number ) HEX: 0 ; inline
-: MAD_ERROR_BUFLEN ( -- number ) HEX: 1 ; inline
-: MAD_ERROR_BUFPTR ( -- number ) HEX: 2 ; inline
-: MAD_ERROR_NOMEM ( -- number ) HEX: 31 ; inline
-: MAD_ERROR_LOSTSYNC ( -- number ) HEX: 101 ; inline
-: MAD_ERROR_BADLAYER ( -- number ) HEX: 102 ; inline
-: MAD_ERROR_BADBITRATE ( -- number ) HEX: 103 ; inline
-: MAD_ERROR_BADSAMPLERATE ( -- number ) HEX: 104 ; inline
-: MAD_ERROR_BADEMPHASIS ( -- number ) HEX: 105 ; inline
-: MAD_ERROR_BADCRC ( -- number ) HEX: 201 ; inline
-: MAD_ERROR_BADBITALLOC ( -- number ) HEX: 211 ; inline
-: MAD_ERROR_BADSCALEFACTOR ( -- number ) HEX: 221 ; inline
-: MAD_ERROR_BADMODE ( -- number ) HEX: 222 ; inline
-: MAD_ERROR_BADFRAMELEN ( -- number ) HEX: 231 ; inline
-: MAD_ERROR_BADBIGVALUES ( -- number ) HEX: 232 ; inline
-: MAD_ERROR_BADBLOCKTYPE ( -- number ) HEX: 233 ; inline
-: MAD_ERROR_BADSCFSI ( -- number ) HEX: 234 ; inline
-: MAD_ERROR_BADDATAPTR ( -- number ) HEX: 235 ; inline
-: MAD_ERROR_BADPART3LEN ( -- number ) HEX: 236 ; inline
-: MAD_ERROR_BADHUFFTABLE ( -- number ) HEX: 237 ; inline
-: MAD_ERROR_BADHUFFDATA ( -- number ) HEX: 238 ; inline
-: MAD_ERROR_BADSTEREO ( -- number ) HEX: 239 ; inline
-
-
-FUNCTION: void mad_decoder_init ( mad_decoder* decoder, void* data, void* input_func, void* header_func, void* filter_func, void* output_func, void* error_func, void* message_func ) ;
-FUNCTION: int mad_decoder_run ( mad_decoder* decoder, mad_decoder_mode mode ) ;
-FUNCTION: void mad_stream_buffer ( mad_stream* stream, uchar* start, ulong length ) ;
-
+++ /dev/null
-Adam Wendt
+++ /dev/null
-! Copyright (C) 2007 Adam Wendt.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-!\r
-USING: alien.c-types io kernel libc mad mad.api math namespaces openal prettyprint sequences tools.interpreter vars ;\r
-IN: mad.player\r
-\r
-VARS: openal-buffer ;\r
-\r
-: get-format ( pcm -- format )\r
- mad_pcm-channels 2 =\r
- [ AL_FORMAT_STEREO16 ] [ AL_FORMAT_MONO16 ] if ;\r
-\r
-: no-error? ( -- ? )\r
- alGetError dup . flush AL_NO_ERROR = ;\r
-\r
-: round ( sample -- rounded )\r
- 1 MAD_F_FRACBITS 16 - shift + ;\r
-\r
-: clip ( sample -- clipped ) MAD_F_ONE 1- min MAD_F_ONE neg max ;\r
-\r
-: quantize ( sample -- quantized )\r
- MAD_F_FRACBITS 1+ 16 - neg shift ;\r
-\r
-: scale-sample ( sample -- scaled )\r
- round clip quantize ;\r
-\r
-: get-needed-size ( pcm -- size )\r
- [ mad_pcm-channels ] keep mad_pcm-length 2 * * ;\r
-\r
-: make-data ( pcm -- )\r
- [ mad_pcm-channels ] keep ! channels pcm\r
- [ mad_pcm-length ] keep swap ! channels pcm length\r
- [ ! channels pcm counter\r
- [ mad_pcm-sample-right ] 2keep ! channels right pcm counter\r
- [ mad_pcm-sample-left ] 2keep ! channels right left pcm counter\r
- drop -rot scale-sample , pick ! channels pcm right channels\r
- 2 = [ scale-sample , ] [ drop ] if ! channels pcm right\r
- ] each 2drop ;\r
-\r
-: array>alien ( alien array -- ) dup length [ pick set-int-nth ] 2each drop ;\r
- \r
-: fill-data ( pcm alien -- )\r
- swap [ make-data ] { } make array>alien ;\r
-\r
-: get-data ( pcm -- size alien )\r
- [ get-needed-size ] keep over\r
- malloc [ fill-data ] keep ;\r
-\r
-: output-openal ( pcm -- ? )\r
- openal-buffer> swap ! buffer pcm\r
- [ get-format ] keep ! buffer format pcm\r
- [ get-data ] keep ! buffer format size alien pcm\r
- mad_pcm-samplerate ! buffer format size alien samplerate\r
- swapd alBufferData no-error?\r
- ;\r
-\r
-: play-mp3 ( filename -- )\r
- gen-buffer >openal-buffer [ output-openal ] >output-callback-var decode-mp3 ;\r
+++ /dev/null
-libmad MP3 library binding
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel io parser lexer words namespaces quotations arrays assocs sequences
- splitting grouping math generalizations ;
-
-IN: mortar
-
-! class { name slots methods class-methods }
-
-: class-name ( class -- name ) dup symbol? [ get ] when first ;
-
-: class-slots ( class -- slots ) dup symbol? [ get ] when second ;
-
-: class-methods ( class -- methods ) dup symbol? [ get ] when third ;
-
-: class-class-methods ( class -- methods ) dup symbol? [ get ] when fourth ;
-
-: class? ( thing -- ? )
-dup array?
-[ dup length 4 = [ first symbol? ] [ drop f ] if ]
-[ drop f ]
-if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: add-method ( class name quot -- )
-rot get class-methods peek swapd set-at ;
-
-: add-class-method ( class name quot -- )
-rot get class-class-methods peek swapd set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! object { class values }
-
-: object-class ( object -- class ) first ;
-
-: object-values ( object -- values ) second ;
-
-: object? ( thing -- ? )
-dup array?
-[ dup length 2 = [ first class? ] [ drop f ] if ]
-[ drop f ]
-if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: is? ( object class -- ? ) swap object-class class-name = ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: new ( class -- object )
-get dup >r class-slots length narray r> swap 2array ;
-
-: new-empty ( class -- object )
-get dup >r class-slots length f <array> r> swap 2array ;
-
-! : new* ( class -- object ) new-empty <- init ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: slot-value ( object slot -- value )
-over object-class class-slots index swap object-values nth ;
-
-: set-slot-value ( object slot value -- object )
-swap pick object-class class-slots index pick object-values set-nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : send-message ( object message -- )
-! over object-class class-methods assoc-stack call ;
-
-: send-message ( object message -- )
-2dup swap object-class class-methods assoc-stack dup
-[ nip call ]
-! [ drop nip "message not understood: " write print flush ]
-[ drop "message not understood: " write print drop ]
-if ;
-
-: <- scan parsed \ send-message parsed ; parsing
-
-! : send-message* ( message n -- )
-! 1+ npick object-class class-methods assoc-stack call ;
-
-: send-message* ( message n -- )
-1+ npick dupd object-class class-methods assoc-stack dup
-[ nip call ]
-[ drop "message not understood: " write print flush ]
-if ;
-
-: <-- scan parsed 2 parsed \ send-message* parsed ; parsing
-
-: <--- scan parsed 3 parsed \ send-message* parsed ; parsing
-
-: <---- scan parsed 4 parsed \ send-message* parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: send-message-to-class ( class message -- )
-over class-class-methods assoc-stack call ;
-
-: <<- scan parsed \ send-message-to-class parsed ; parsing
-
-: send-message-to-class* ( message n -- )
-1+ npick class-class-methods assoc-stack call ;
-
-: <<-- scan parsed 2 parsed \ send-message-to-class* parsed ; parsing
-
-: <<--- scan parsed 3 parsed \ send-message-to-class* parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: send-message-next ( object message -- )
-over object-class class-methods but-last assoc-stack call ;
-
-: <-~ scan parsed \ send-message-next parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : new* ( class -- object ) <<- create ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-IN: slot-accessors
-
-IN: mortar
-
-! : generate-slot-getter ( name -- )
-! "$" over append "slot-accessors" create swap [ slot-value ] curry
-! define-compound ;
-
-: generate-slot-getter ( name -- )
-"$" over append "slot-accessors" create swap [ slot-value ] curry define ;
-
-! : generate-slot-setter ( name -- )
-! ">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
-! define-compound ;
-
-: generate-slot-setter ( name -- )
-">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
-define ;
-
-: generate-slot-accessors ( name -- )
-dup
-generate-slot-getter
-generate-slot-setter ;
-
-: accessors ( seq -- seq ) dup peek [ generate-slot-accessors ] each ; parsing
-
-! : slots:
-! ";" parse-tokens dup [ generate-slot-accessors ] each parsed ; parsing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : <symbol> ( string -- symbol ) in get create dup define-symbol ;
-
-: empty-method-table ( -- array ) H{ } clone 1array ;
-
-! : define-simple-class ( name parent slots -- )
-! >r >r <symbol>
-! r> dup class-slots r> append
-! swap dup class-methods empty-method-table append
-! swap class-class-methods empty-method-table append
-! 4array dup first set-global ;
-
-: define-simple-class ( name parent slots -- )
->r dup class-slots r> append
-swap dup class-methods empty-method-table append
-swap class-class-methods empty-method-table append
-4array dup first set-global ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: define-independent-class ( name slots -- )
-empty-method-table empty-method-table 4array dup first set-global ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: add-methods ( class seq -- ) 2 group [ first2 add-method ] with each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: !( ")" parse-tokens drop ; parsing
\ No newline at end of file
+++ /dev/null
-
-USING: mortar ;
-
-IN: mortar.sugar
-
-: new* ( class -- object ) <<- create ;
\ No newline at end of file
+++ /dev/null
-extensions
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: kernel namespaces namespaces.private quotations sequences
- assocs.lib math.parser math generalizations locals mirrors
- macros ;
-
-IN: namespaces.lib
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: save-namestack ( quot -- ) namestack slip set-namestack ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: set* ( val var -- ) namestack* set-assoc-stack ;
-
-: make-object ( quot class -- object )
- new [ <mirror> swap bind ] keep ; inline
-
-: with-object ( object quot -- )
- [ <mirror> ] dip bind ; inline
+++ /dev/null
-Non-core namespace words
+++ /dev/null
-collections
+++ /dev/null
-
-USING: arrays sequences ;
-
-IN: obj.alist
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-PREDICATE: alist < sequence [ pair? ] all? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: kernel sequences sets combinators.cleave
- obj obj.view obj.util obj.print ;
-
-IN: obj.examples.todo
-
-SYM: person types adjoin
-SYM: todo types adjoin
-
-SYM: owners properties adjoin
-SYM: eta properties adjoin
-SYM: notes properties adjoin
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: slava { type person } define-object
-SYM: doug { type person } define-object
-SYM: ed { type person } define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: compiler-bugs
- {
- type todo
- owners { slava }
- notes {
- "Investitage FEP on Terrorist"
- "Problem with cutler in VirtualBox?"
- }
- }
-define-object
-
-SYM: remove-old-accessors-from-core
- {
- type todo
- owners { slava }
- }
-define-object
-
-SYM: move-db-and-web-framework-to-basis
- {
- type todo
- owners { slava }
- }
-define-object
-
-SYM: remove-old-accessors-from-basis
- {
- type todo
- owners { doug ed }
- }
-define-object
-
-SYM: blas-on-bsd
- {
- type todo
- owners { slava doug }
- }
-define-object
-
-SYM: multi-methods-backend
- {
- type todo
- owners { slava }
- }
-define-object
-
-SYM: update-core-for-multi-methods { type todo owners { slava } } define-object
-SYM: update-basis-for-multi-methods { type todo } define-object
-SYM: update-extra-for-multi-methods { type todo } define-object
-
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: todo-list ( -- )
- objects [ type -> todo = ] filter
- [ { [ self -> ] [ owners -> ] [ eta -> ] } 1arr ]
- map
- { "ITEM" "OWNERS" "ETA" } prefix
- print-table ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: kernel namespaces sequences assocs sequences.deep obj ;
-
-IN: obj.misc
-
-: related ( obj -- seq )
- objects dupd remove [ get values flatten member? ] with filter ;
-
+++ /dev/null
-
-USING: kernel words namespaces arrays vectors hashtables
- sequences assocs sets grouping
- combinators.conditional
- combinators.short-circuit
- obj.util obj.alist ;
-
-IN: obj
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: properties ( -- properties ) V{ } ;
-
-SYM: self properties adjoin
-SYM: type properties adjoin
-SYM: title properties adjoin
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: types ( -- types ) V{ } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: >obj ( val -- obj ) [ symbol? ] [ get ] [ ] 1if ;
-
-: -> ( obj pro -- val ) swap >obj at ;
-
-PREDICATE: obj < alist { [ self -> ] [ type -> ] } 1&& ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: objects ( -- objects ) V{ } ;
-
-: define-object ( symbol table -- )
- 2 group >vector
- self rot 2array prefix
- dup dup self -> set-global
- self -> objects adjoin ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-PREDICATE: ptr < symbol get obj? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: sets obj obj.util obj.view ;
-
-IN: obj.papers
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: title properties adjoin
-SYM: abstract properties adjoin
-SYM: authors properties adjoin
-SYM: file properties adjoin
-SYM: date properties adjoin
-SYM: participants properties adjoin
-SYM: description properties adjoin
-
-SYM: chapter properties adjoin
-SYM: section properties adjoin
-SYM: paragraph properties adjoin
-SYM: content properties adjoin
-
-SYM: subjects properties adjoin
-SYM: source properties adjoin
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: paper types adjoin
-SYM: person types adjoin
-SYM: event types adjoin
-
-SYM: excerpt types adjoin
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: bay-wei-chang { type person } define-object
-SYM: chuck-moore { type person } define-object
-SYM: craig-chambers { type person } define-object
-SYM: david-ungar { type person } define-object
-SYM: frank-g-halasz { type person } define-object
-SYM: gerald-jay-sussman { type person } define-object
-SYM: guy-lewis-steele-jr { type person } define-object
-SYM: randall-b-smith { type person } define-object
-SYM: randall-h-trigg { type person } define-object
-SYM: robert-adams { type person } define-object
-SYM: russell-noftsker { type person } define-object
-SYM: thomas-p-moran { type person } define-object
-SYM: urs-holzle { type person } define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: programming-as-an-experience
- {
- type paper
- title "Programming as an Experience: The Inspiration for Self"
- abstract "The Self system attempts to integrate intellectual and non-intellectual aspects of programming to create an overall experience. The language semantics, user interface, and implementation each help create this integrated experience. The language semantics embed the programmer in a uniform world of simple ob jects that can be modified without appealing to definitions of abstractions. In a similar way, the graphical interface puts the user into a uniform world of tangible objects that can be directly manipulated and changed without switching modes. The implementation strives to support the world-of-objects illusion by minimiz ing perceptible pauses and by providing true source-level semantics without sac rificing performance. As a side benefit, it encourages factoring. Although we see areas that fall short of the vision, on the whole, the language, interface, and im plementation conspire so that the Self programmer lives and acts in a consistent and malleable world of objects."
- authors { randall-b-smith david-ungar }
- date 1995
- }
-define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: self-the-power-of-simplicity
- {
- type paper
- title "Self: The Power of Simplicity"
- abstract "Self is an object-oriented language for exploratory programming based on a small number of simple and concrete ideas: prototypes, slots, and behavior. Prototypes combine inheritance and instantiation to provide a framework that is simpler and more flexible than most object-oriented languages. Slots unite variables and procedures into a single construct. This permits the inheritance hierarchy to take over the function of lexical scoping in conventional languages. Finally, because Self does not distinguish state from behavior, it narrows the gaps between ordinary objects, procedures, and closures. Self's simplicity and expressiveness offer new insights into object-oriented computation."
- authors { randall-b-smith david-ungar }
- date 1987
- }
-define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: parents-are-shared-parts
- {
- type paper
- title "Parents are Shared Parts: Inheritance and Encapsulation in Self"
- abstract "The design of inheritance and encapsulation in Self, an object-oriented language based on prototypes, results from understanding that inheritance allows parents to be shared parts of their children. The programmer resolves ambiguities arising from multiple inheritance by prioritizing an object's parents. Unifying unordered and ordered multiple inheritance supports differential programming of abstractions and methods, combination of unrelated abstractions, unequal combination of abstractions, and mixins. In Self, a private slot may be accessed if the sending method is a shared part of the receiver, allowing privileged communication between related objects. Thus, classless Self enjoys the benefits of class-based encapsulation."
- authors { craig-chambers david-ungar bay-wei-chang urs-holzle }
- date 1991
- }
-define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: organizing-programs-without-classes
- {
- type paper
- title "Organizing Programs Without Classes"
- abstract "All organizational functions carried out by classes can be accomplished in a simple and natural way by object inheritance in classless languages, with no need for special mechanisms. A single model--dividing types into prototypes and traits--supports sharing of behavior and extending or replacing representations. A natural extension, dynamic object inheritance, can model behavioral modes. Object inheritance can also be used to provide structured name spaces for well-known objects. Classless languages can even express 'class-based' encapsulation. These stylized uses of object inheritance become instantly recognizable idioms, and extend the repertory of organizing principles to cover a wider range of programs."
- authors { david-ungar craig-chambers bay-wei-chang urs-holzle }
- date 1991
- }
-define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: scheme-an-interpreter-for-extended-lambda-calculus
- {
- type paper
- title "Scheme: An Interpreter for Extended Lambda Calculus"
- abstract "Inspired by ACTORS [Greif and Hewitt] [Smith and Hewitt], we have implemented an interpreter for a LISP-like language, SCHEME, based on the lambda calculus [Church], but extended for side effects, multiprocessing, and process synchronization. The purpose of this implementation is tutorial. We wish to: (1) alleviate the confusion caused by Micro-PLANNER, CONNIVER, etc. by clarifying the embedding of non-recursive control structures in a recursive host language like LISP. (2) explain how to use these control structures, independent of such issues as pattern matching and data base manipulation. (3) have a simple concrete experimental domain for certain issues of programming semantics and style."
- authors { gerald-jay-sussman guy-lewis-steele-jr }
- date 1975
- }
-define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: symbolics-is-founded
- {
- type event
- participants { russell-noftsker robert-adams }
- date 1980
- }
-define-object
-
-SYM: symbolics-funding-from-gi
- {
- type event
- description "Symbolics receives $500,000 from General Instruments"
- date 1982
- }
-define-object
-
-SYM: symbolics-files-for-bankruptcy
- {
- type event
- date "1993-01-28"
- }
-define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: the-evolution-of-forth
- {
- type paper
- title "The Evolution of Forth"
- authors { chuck-moore "elizabeth-d-rather" "donald-r-colburn" }
- abstract
- "Forth is unique among programming languages in that its development and proliferation has been a grass-roots effort unsupported by any major corporate or academic sponsors. Originally conceived and developed by a single individual, its later development has progressed under two significant influences: professional programmers who developed tools to solve application problems and then commercialized them, and the interests of hobbyists concerned with free distribution of Forth. These influences have produced a language markedly different from traditional programming languages."
- date 1993
- }
-define-object
-
-SYM: first-complete-stand-alone-forth
- {
- type event
- participants { chuck-moore }
- date 1971
- }
-define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: notecards-in-a-nutshell
- {
- type paper
- authors { frank-g-halasz thomas-p-moran randall-h-trigg }
- date 1987
- }
-define-object
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYM: the-evolution-of-forth-excerpt-2-1-1
- {
- type excerpt
- source the-evolution-of-forth
- chapter 2
- section 1
- paragraph 1
- content
- "Moore developed the first complete, stand-alone implementation of Forth in 1971 for the 11-meter radio telescope operated by the National Radio Astronomy Observatory (NRAO) at Kitt Peak, Arizona. This system ran on two early minicomputers (a 16 KB DDP-116 and a 32 KB H316) joined by a serial link. Both a multiprogrammed system and a multiprocessor system (in that both computers shared responsibility for controlling the telescope and its scientific instruments), it was responsible for pointing and tracking the telescope, collecting data and recording it on magnetic tape, and supporting an interactive graphics terminal on which an astronomer could analyze previously recorded data. The multiprogrammed nature of the system allowed all these functions to be performed concurrently, without timing conflicts or other interference."
- subjects { chuck-moore first-complete-stand-alone-forth }
- }
-define-object
-
+++ /dev/null
-
-USING: kernel arrays strings sequences assocs io io.styles prettyprint colors
- combinators.conditional ;
-
-IN: obj.print
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: write-wrapped ( string -- ) H{ { wrap-margin 500 } } [ write ] with-nesting ;
-
-! : print-elt ( val -- )
-! {
-! { [ string? ] [ write-wrapped ] }
-! { [ array? ] [ [ . ] each ] }
-! { [ drop t ] [ . ] }
-! }
-! 1cond ;
-
-USING: accessors vocabs help.markup ;
-
-: print-elt ( val -- )
- {
- { [ vocab? ] [ [ name>> ] [ ] bi write-object ] }
- { [ string? ] [ write-wrapped ] }
- { [ array? ] [ [ . ] each ] }
- { [ drop t ] [ . ] }
- }
- 1cond ;
-
-: print-grid ( grid -- )
- H{ { table-gap { 10 10 } } { table-border T{ rgba f 0 0 0 1 } } }
- [ [ [ [ [ print-elt ] with-cell ] each ] with-row ] each ] tabular-output ;
-
-: print-table ( assoc -- ) >alist print-grid ;
-
-: print-seq ( seq -- ) [ 1array ] map print-grid ;
-
+++ /dev/null
-
-USING: kernel parser words ;
-
-IN: obj.util
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: SYM: CREATE-WORD dup define-symbol parsed ; parsing
\ No newline at end of file
+++ /dev/null
-
-USING: kernel words namespaces arrays sequences prettyprint
- help.topics help.markup bake combinators.cleave
- obj obj.misc obj.print ;
-
-IN: obj.view
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: $tab ( seq -- ) first print-table ;
-: $obj ( seq -- ) first print-table ;
-: $seq ( seq -- ) first print-seq ;
-: $ptr ( seq -- ) first get print-table ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-PREDICATE: obj-type < symbol types member? ;
-
-M: obj-type article-title ( type -- title ) unparse ;
-
-M: obj-type article-content ( type -- content )
- objects [ type -> = ] with filter
- { $seq , } bake ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: ptr article-title ( ptr -- title ) [ title -> ] [ unparse ] bi or ;
-
-M: ptr article-content ( ptr -- content )
- {
- [ get { $obj , } bake ]
- [ drop { $heading "Related\n" } ]
- [ related { $seq , } bake ]
- }
- 1arr ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-PREDICATE: obj-list < word \ objects = ;
-
-M: obj-list article-title ( objects -- title ) drop "Objects" ;
-
-! M: obj-list article-content ( objects -- title )
-! execute
-! [ [ type -> ] [ ] bi 2array ] map
-! { $tab , } bake ;
-
-M: obj-list article-content ( objects -- title )
- drop
- objects
- [ [ type -> ] [ ] bi 2array ] map
- { $tab , } bake ;
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+IN: ori.tests
+USING: ori tools.test ;
+
+\ pitch-up must-infer
+\ pitch-down must-infer
+\ turn-left must-infer
+\ turn-right must-infer
+\ roll-left must-infer
+\ roll-right must-infer
--- /dev/null
+
+USING: kernel namespaces make accessors
+ math math.constants math.functions math.matrices math.vectors
+ sequences splitting grouping self math.trig ;
+
+IN: ori
+
+TUPLE: ori val ;
+
+C: <ori> ori
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ori> ( -- val ) self> val>> ;
+
+: >ori ( val -- ) self> (>>val) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-matrix ( quot width -- matrix ) [ { } make ] dip group ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! These rotation matrices are from
+! `Computer Graphics: Principles and Practice'
+
+: Rz ( angle -- Rx ) deg>rad
+[ dup cos , dup sin neg , 0 ,
+ dup sin , dup cos , 0 ,
+ 0 , 0 , 1 , ] 3 make-matrix nip ;
+
+: Ry ( angle -- Ry ) deg>rad
+[ dup cos , 0 , dup sin ,
+ 0 , 1 , 0 ,
+ dup sin neg , 0 , dup cos , ] 3 make-matrix nip ;
+
+: Rx ( angle -- Rz ) deg>rad
+[ 1 , 0 , 0 ,
+ 0 , dup cos , dup sin neg ,
+ 0 , dup sin , dup cos , ] 3 make-matrix nip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: apply-rotation ( rotation -- ) ori> swap m. >ori ;
+
+: rotate-x ( angle -- ) Rx apply-rotation ;
+: rotate-y ( angle -- ) Ry apply-rotation ;
+: rotate-z ( angle -- ) Rz apply-rotation ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pitch-up ( angle -- ) neg rotate-x ;
+: pitch-down ( angle -- ) rotate-x ;
+
+: turn-left ( angle -- ) rotate-y ;
+: turn-right ( angle -- ) neg rotate-y ;
+
+: roll-left ( angle -- ) neg rotate-z ;
+: roll-right ( angle -- ) rotate-z ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! roll-until-horizontal
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: V ( -- V ) { 0 1 0 } ;
+
+: X ( -- 3array ) ori> [ first ] map ;
+: Y ( -- 3array ) ori> [ second ] map ;
+: Z ( -- 3array ) ori> [ third ] map ;
+
+: set-X ( seq -- ) ori> [ set-first ] 2each ;
+: set-Y ( seq -- ) ori> [ set-second ] 2each ;
+: set-Z ( seq -- ) ori> [ set-third ] 2each ;
+
+: roll-until-horizontal ( -- )
+V Z cross normalize set-X
+Z X cross normalize set-Y ;
+
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel math math.functions math.vectors sequences self
+accessors ;
+
+IN: pos
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: pos val ;
+
+C: <pos> pos
+
+: pos> ( -- val ) self> val>> ;
+
+: >pos ( val -- ) self> (>>val) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: distance ( pos pos -- n ) val>> swap val>> v- [ sq ] map sum sqrt ;
+
+: move-by ( point -- ) pos> v+ >pos ;
+
+++ /dev/null
-Gavin Harrison
+++ /dev/null
-! Copyright (C) 2007 Gavin Harrison
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel sequences arrays vectors namespaces math strings
- combinators continuations quotations io assocs ascii ;
-
-IN: prolog
-
-SYMBOL: pldb
-SYMBOL: plchoice
-
-: init-pl ( -- ) V{ } clone pldb set V{ } clone plchoice set ;
-
-: reset-choice ( -- ) V{ } clone plchoice set ;
-: remove-choice ( -- ) plchoice get pop drop ;
-: add-choice ( continuation -- )
- dup continuation? [ plchoice get push ] [ drop ] if ;
-: last-choice ( -- ) plchoice get pop continue ;
-
-: rules ( -- vector ) pldb get ;
-: rule ( n -- rule ) dup rules length >= [ drop "No." ] [ rules nth ] if ;
-
-: var? ( pl-obj -- ? )
- dup string? [ 0 swap nth LETTER? ] [ drop f ] if ;
-: const? ( pl-obj -- ? ) var? not ;
-
-: check-arity ( pat fact -- pattern fact ? ) 2dup [ length ] 2apply = ;
-: check-elements ( pat fact -- ? ) [ over var? [ 2drop t ] [ = ] if ] 2all? ;
-: (double-bound) ( key value assoc -- ? )
- pick over at* [ pick = >r 3drop r> ] [ drop swapd set-at t ] if ;
-: single-bound? ( pat-d pat-f -- ? )
- H{ } clone [ (double-bound) ] curry 2all? ;
-: match-pattern ( pat fact -- ? )
- check-arity [ 2dup check-elements -rot single-bound? and ] [ 2drop f ] if ;
-: good-result? ( pat fact -- pat fact ? )
- 2dup dup "No." = [ 2drop t ] [ match-pattern ] if ;
-
-: add-rule ( name pat body -- ) 3array rules dup length swap set-nth ;
-
-: (lookup-rule) ( name num -- pat-f rules )
- dup rule dup "No." = >r 0 swap nth swapd dupd = swapd r> or
- [ dup rule [ ] callcc0 add-choice ] when
- dup number? [ 1+ (lookup-rule) ] [ 2nip ] if ;
-
-: add-bindings ( pat-d pat-f binds -- binds )
- clone
- [ over var? over const? or
- [ 2drop ] [ rot dup >r set-at r> ] if
- ] 2reduce ;
-: init-binds ( pat-d pat-f -- binds ) V{ } clone add-bindings >alist ;
-
-: replace-if-bound ( binds elt -- binds elt' )
- over 2dup key? [ at ] [ drop ] if ;
-: deep-replace ( binds seq -- binds seq' )
- [ dup var? [ replace-if-bound ]
- [ dup array? [ dupd deep-replace nip ] when ] if
- ] map ;
-
-: backtrace? ( result -- )
- dup "No." = [ remove-choice last-choice ]
- [ [ last-choice ] unless ] if ;
-
-: resolve-rule ( pat-d pat-f rule-body -- binds )
- >r 2dup init-binds r> [ deep-replace >quotation call dup backtrace?
- dup t = [ drop ] when ] each ;
-
-: rule>pattern ( rule -- pattern ) 1 swap nth ;
-: rule>body ( rule -- body ) 2 swap nth ;
-
-: binds>fact ( pat-d pat-f binds -- fact )
- [ 2dup key? [ at ] [ drop ] if ] curry map good-result?
- [ nip ] [ last-choice ] if ;
-
-: lookup-rule ( name pat -- fact )
- swap 0 (lookup-rule) dup "No." =
- [ nip ]
- [ dup rule>pattern swapd check-arity
- [ rot rule>body resolve-rule dup -roll binds>fact nip ] [ last-choice ] if
- ] if ;
-
-: binding-resolve ( binds name pat -- binds )
- tuck lookup-rule dup backtrace? spin add-bindings ;
-
-: is ( binds val var -- binds ) rot [ set-at ] keep ;
+++ /dev/null
-Implementation of an embedded prolog for factor
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel math.constants ;
-IN: random-tester.databank
-
-: databank ( -- array )
- {
- ! V{ } H{ } V{ 3 } { 3 } { } "" "asdf"
- pi 1/0. -1/0. 0/0. [ ]
- f t "" 0 0.0 3.14 2 -3 -7 20 3/4 -3/4 1.2/3 3.5
- C{ 2 2 } C{ 1/0. 1/0. }
- } ;
-
+++ /dev/null
-USING: compiler continuations io kernel math namespaces
-prettyprint quotations random sequences vectors
-compiler.units ;
-USING: random-tester.databank random-tester.safe-words
-random-tester.random ;
-IN: random-tester
-
-SYMBOL: errored
-SYMBOL: before
-SYMBOL: after
-SYMBOL: quot
-ERROR: random-tester-error ;
-
-: setup-test ( #data #code -- data... quot )
- #! Variable stack effect
- >r [ databank random ] times r>
- ! 200 300 random-cond ;
- ! random-if ;
- [ drop \ safe-words get random ] map >quotation ;
-
-: test-compiler ! ( data... quot -- ... )
- errored off
- dup quot set
- datastack 1 head* before set
- [ call ] [ drop ] recover
- datastack after set
- clear
- before get [ ] each
- quot get [ compile-call ] [ errored on ] recover ;
-
-: do-test ! ( data... quot -- )
- .s flush test-compiler
- errored get [
- datastack after get 2dup = [
- 2drop
- ] [
- [ . ] each
- "--" print
- [ . ] each
- quot get .
- random-tester-error
- ] if
- ] unless clear ;
-
-: random-test1 ( #data #code -- )
- setup-test do-test ;
-
-: random-test2 ( -- )
- 3 2 setup-test do-test ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel math sequences namespaces hashtables words
-arrays parser compiler syntax io prettyprint random
-math.constants math.functions layouts random-tester.utils
-random-tester.safe-words quotations fry combinators ;
-IN: random-tester
-
-! Tweak me
-: max-length 15 ; inline
-: max-value 1000000000 ; inline
-
-! varying bit-length random number
-: random-bits ( n -- int )
- random 2 swap ^ random ;
-
-: random-seq ( -- seq )
- { [ ] { } V{ } "" } random
- [ max-length random [ max-value random , ] times ] swap make ;
-
-: random-string
- [ max-length random [ max-value random , ] times ] "" make ;
-
-: special-integers ( -- seq ) \ special-integers get ;
-[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ]
-{ } make \ special-integers set-global
-: special-floats ( -- seq ) \ special-floats get ;
-[ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
-{ } make \ special-floats set-global
-: special-complexes ( -- seq ) \ special-complexes get ;
-[
- { -1 0 1 C{ 0 1 } C{ 0 -1 } } %
- e , e neg , pi , pi neg ,
- 0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
- pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
- e neg e neg rect> , e e rect> ,
-] { } make \ special-complexes set-global
-
-: random-fixnum ( -- fixnum )
- most-positive-fixnum random 1+ 50% [ neg 1- ] when >fixnum ;
-
-: random-bignum ( -- bignum )
- 400 random-bits first-bignum + 50% [ neg ] when ;
-
-: random-integer ( -- n )
- 50% [
- random-fixnum
- ] [
- 50% [ random-bignum ] [ special-integers get random ] if
- ] if ;
-
-: random-positive-integer ( -- int )
- random-integer dup 0 < [
- neg
- ] [
- dup 0 = [ 1 + ] when
- ] if ;
-
-: random-ratio ( -- ratio )
- 1000000000 dup [ random ] bi@ 1+ / 50% [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
-
-: random-float ( -- float )
- 50% [ random-ratio ] [ special-floats get random ] if
- 50%
- [ .0000000000000000001 /f ] [ 50% [ .00000000000000001 * ] when ] if
- >float ;
-
-: random-number ( -- number )
- {
- [ random-integer ]
- [ random-ratio ]
- [ random-float ]
- } do-one ;
-
-: random-complex ( -- C )
- random-number random-number rect> ;
-
-: random-quot ( n -- quot )
- [ \ safe-words get random ] replicate >quotation ;
-
-: random-if ( n -- quot )
- [ random-quot ] [ random-quot ] bi
- '[ , , if ] ;
-
-: random-cond ( m n -- quot )
- [ '[ , [ random-quot ] [ random-quot ] bi 2array ] replicate ]
- [ random-quot ] bi suffix
- '[ , cond ] ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel namespaces sequences sets sorting vocabs ;
-USING: arrays assocs generic hashtables
-math math.intervals math.parser math.order math.functions
-refs shuffle vectors words ;
-IN: random-tester.safe-words
-
-: ?-words
- {
- /f
-
- bits>float bits>double
- float>bits double>bits
-
- >bignum >boolean >fixnum >float
-
- array? integer? complex? value-ref? ref? key-ref?
- interval? number?
- wrapper? tuple?
- [-1,1]? between? bignum? both? either? eq? equal? even? fixnum?
- float? fp-nan? hashtable? interval-contains? interval-subset?
- interval? key-ref? key? number? odd? pair? power-of-2?
- ratio? rational? real? zero? assoc? curry? vector? callstack?
-
- 2^ not
- ! arrays
- resize-array <array>
- ! assocs
- (assoc-stack)
- new-assoc
- assoc-like
- <hashtable>
- all-integers? (all-integers?) ! hangs?
- assoc-push-if
-
- (clone) assoc-clone-like ! SYMBOL: foo foo dup (clone) =
- } ;
-
-: bignum-words
- {
- next-power-of-2 (next-power-of-2)
- times
- hashcode hashcode*
- } ;
-
-: initialization-words
- {
- init-namespaces
- } ;
-
-: stack-words
- {
- dup
- drop 2drop 3drop
- roll -roll 2swap
-
- >r r>
- } ;
-
-: stateful-words
- {
- counter
- gensym
- } ;
-
-: foo-words
- {
- set-retainstack
- retainstack callstack
- datastack
- callstack>array
-
- curry 2curry 3curry compose 3compose
- (assoc-each)
- } ;
-
-: exit-words
- {
- call-clear die
- } ;
-
-: bad-words ( -- array )
- [
- ?-words %
- bignum-words %
- initialization-words %
- stack-words %
- stateful-words %
- exit-words %
- foo-words %
- ] { } make ;
-
-: safe-words ( -- array )
- {
- ! "accessors"
- "alists" "arrays" "assocs" "bit-arrays" "byte-arrays"
- ! "classes" "combinators" "compiler" "continuations"
- ! "core-foundation" "definitions" "documents"
- ! "float-arrays" "generic" "graphs" "growable"
- "hashtables" ! io.*
- "kernel" "math"
- "math.bitfields" "math.complex" "math.constants" "math.floats"
- "math.functions" "math.integers" "math.intervals" "math.libm"
- "math.parser" "math.order" "math.ratios" "math.vectors"
- ! "namespaces"
- "quotations" "sbufs"
- ! "queues" "strings" "sequences"
- "sets"
- "vectors"
- ! "words"
- } [ words ] map concat bad-words diff natural-sort ;
-
-safe-words \ safe-words set-global
-
-! foo dup (clone) = .
-! foo dup clone = .
-! f [ byte-array>bignum assoc-clone-like ] compile-1
-! 2 3.14 [ number= ] compile-1
-! 3.14 [ <vector> assoc? ] compile-1
-! -3 [ ] 2 [ byte-array>bignum denominator ] compile-1
-! : foo ( x -- y ) euler bitand ; { foo } compile 20 foo
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: arrays assocs combinators.lib continuations kernel
-math math.functions memoize namespaces quotations random sequences
-sequences.private shuffle ;
-IN: random-tester.utils
-
-: %chance ( n -- ? )
- 100 random > ;
-
-: 10% ( -- ? ) 10 %chance ;
-: 20% ( -- ? ) 20 %chance ;
-: 30% ( -- ? ) 30 %chance ;
-: 40% ( -- ? ) 40 %chance ;
-: 50% ( -- ? ) 50 %chance ;
-: 60% ( -- ? ) 60 %chance ;
-: 70% ( -- ? ) 70 %chance ;
-: 80% ( -- ? ) 80 %chance ;
-: 90% ( -- ? ) 90 %chance ;
-
-: call-if ( quot ? -- ) swap when ; inline
-
-: with-10% ( quot -- ) 10% call-if ; inline
-: with-20% ( quot -- ) 20% call-if ; inline
-: with-30% ( quot -- ) 30% call-if ; inline
-: with-40% ( quot -- ) 40% call-if ; inline
-: with-50% ( quot -- ) 50% call-if ; inline
-: with-60% ( quot -- ) 60% call-if ; inline
-: with-70% ( quot -- ) 70% call-if ; inline
-: with-80% ( quot -- ) 80% call-if ; inline
-: with-90% ( quot -- ) 90% call-if ; inline
-
-: random-key keys random ;
-: random-value [ random-key ] keep at ;
-
-: do-one ( seq -- ) random call ; inline
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces arrays quotations sequences assocs combinators
+ mirrors math math.vectors random macros fry ;
+
+IN: random-weighted
+
+: probabilities ( weights -- probabilities ) dup sum v/n ;
+
+: layers ( probabilities -- layers )
+dup length 1+ [ head ] with map rest [ sum ] map ;
+
+: random-weighted ( weights -- elt )
+probabilities layers [ 1000 * ] map 1000 random [ > ] curry find drop ;
+
+: random-weighted* ( seq -- elt )
+dup [ second ] map swap [ first ] map random-weighted swap nth ;
+
+MACRO: call-random-weighted ( exp -- )
+ [ keys ] [ values <enum> >alist ] bi
+ '[ _ random-weighted _ case ] ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: namespaces threads
- unix.process unix.linux.if unix.linux.ifreq unix.linux.route
- raptor.cron ;
-
-IN: raptor
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Networking
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: configure-lo ( -- )
- "lo" "127.0.0.1" set-if-addr
- "lo" { IFF_UP } flags set-if-flags ;
-
-: configure-eth1 ( -- )
- "eth1" "192.168.1.10" set-if-addr
- "eth1" { IFF_UP IFF_MULTICAST } flags set-if-flags ;
-
-: configure-route ( -- )
- "0.0.0.0" "192.168.1.1" "0.0.0.0" { RTF_UP RTF_GATEWAY } flags route ;
-
-[
- configure-lo
- configure-eth1
- configure-route
-] networking-hook set-global
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Filesystems
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-"/dev/hda1" root-device set-global
-
-{ "/dev/hda5" } swap-devices set-global
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! boot-hook
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[
- start-wait-loop
-
- ! rcS.d
-
- "mountvirtfs" start-service
-
- ! "hostname.sh" start-service
- "narodnik" set-hostname
-
- "keymap.sh" start-service
- "linux-restricted-modules-common" start-service
- "udev" start-service
- "mountdevsubfs" start-service
- "module-init-tools" start-service
- "procps.sh" start-service
-
- ! "checkroot.sh" start-service
-
- activate-swap
- mount-root
-
- "mtab" start-service
- "checkfs.sh" start-service
- "mountall.sh" start-service
-
- start-networking
-! "loopback" start-service
-! "networking" start-service
-
- "hwclock.sh" start-service
- "displayconfig-hwprobe.py" start-service
- "screen" start-service
- "x11-common" start-service
- "bootmisc.sh" start-service
- "urandom" start-service
-
- ! rc2.d
-
- "vbesave" start-service
- "acpid" start-service
- "powernowd.early" start-service
- "sysklogd" start-service
- "klogd" start-service
- "dbus" start-service
- "apmd" start-service
- "hotkey-setup" start-service
- "laptop-mode" start-service
- "makedev" start-service
- "nvidia-kernel" start-service
- "postfix" start-service
- "powernowd" start-service
- "ntp-server" start-service
- "binfmt-support" start-service
- "acpi-support" start-service
- "rc.local" start-service
- "rmnologin" start-service
-
- schedule-cron-jobs
-
- [ [ "/dev/tty2" tty-listener ] forever ] in-thread
- [ [ "/dev/tty3" tty-listener ] forever ] in-thread
- [ [ "/dev/tty4" tty-listener ] forever ] in-thread
- [ [ "/dev/tty5" getty ] forever ] in-thread
- [ [ "/dev/tty6" getty ] forever ] in-thread
-
-] boot-hook set-global
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! reboot-hook
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[
- "acpi-support" stop-service
- "apmd" stop-service
- "dbus" stop-service
- "hotkey-setup" stop-service
- "laptop-mode" stop-service
- "makedev" stop-service
- "nvidia-kernel" stop-service
- "powernowd" stop-service
- "acpid" stop-service
- "hwclock.sh" stop-service
- "alsa-utils" stop-service
- "klogd" stop-service
- "binfmt-support" stop-service
- "sysklogd" stop-service
- "linux-restricted-modules-common" stop-service
- "sendsigs" stop-service
- "urandom" stop-service
- "umountnfs.sh" stop-service
- "networking" stop-service
- "umountfs" stop-service
- "umountroot" stop-service
- "reboot" stop-service
-] reboot-hook set-global
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! shutdown-hook
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[
- "acpi-support" stop-service
- "apmd" stop-service
- "dbus" stop-service
- "hotkey-setup" stop-service
- "laptop-mode" stop-service
- "makedev" stop-service
- "nvidia-kernel" stop-service
- "postfix" stop-service
- "powernowd" stop-service
- "acpid" stop-service
- "hwclock.sh" stop-service
- "alsa-utils" stop-service
- "klogd" stop-service
- "binfmt-support" stop-service
- "sysklogd" stop-service
- "linux-restricted-modules-common" stop-service
- "sendsigs" stop-service
- "urandom" stop-service
- "umountnfs.sh" stop-service
- "umountfs" stop-service
- "umountroot" stop-service
- "halt" stop-service
-] shutdown-hook set-global
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces threads sequences calendar
- combinators.lib debugger ;
-
-IN: raptor.cron
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: when minute hour day-of-month month day-of-week ;
-
-C: <when> when
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: slot-match? ( now-slot when-slot -- ? ) dup f = [ 2drop t ] [ member? ] if ;
-
-: minute-match? ( now when -- ? )
- [ timestamp-minute ] [ when-minute ] bi* slot-match? ;
-
-: hour-match? ( now when -- ? )
- [ timestamp-hour ] [ when-hour ] bi* slot-match? ;
-
-: day-of-month-match? ( now when -- ? )
- [ timestamp-day ] [ when-day-of-month ] bi* slot-match? ;
-
-: month-match? ( now when -- ? )
- [ timestamp-month ] [ when-month ] bi* slot-match? ;
-
-: day-of-week-match? ( now when -- ? )
- [ day-of-week ] [ when-day-of-week ] bi* slot-match? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: when=now? ( when -- ? )
- now swap
- { [ minute-match? ]
- [ hour-match? ]
- [ day-of-month-match? ]
- [ month-match? ]
- [ day-of-week-match? ] }
- <--&& ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: recurring-job ( when quot -- )
- [ swap when=now? [ try ] [ drop ] if 60000 sleep ] [ recurring-job ] 2bi ;
-
-: schedule ( when quot -- ) [ recurring-job ] 2curry in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: cron-jobs-hourly
-SYMBOL: cron-jobs-daily
-SYMBOL: cron-jobs-weekly
-SYMBOL: cron-jobs-monthly
-
-: schedule-cron-jobs ( -- )
- { 17 } f f f f <when> [ cron-jobs-hourly get call ] schedule
- { 25 } { 6 } f f f <when> [ cron-jobs-daily get call ] schedule
- { 47 } { 6 } f f { 7 } <when> [ cron-jobs-weekly get call ] schedule
- { 52 } { 6 } { 1 } f f <when> [ cron-jobs-monthly get call ] schedule ;
-
+++ /dev/null
-unportable
+++ /dev/null
-
-USING: kernel namespaces threads arrays sequences
- raptor raptor.cron ;
-
-IN: raptor
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[
- "/etc/cron.daily/apt" fork-exec-arg
- "/etc/cron.daily/aptitude" fork-exec-arg
- "/etc/cron.daily/bsdmainutils" fork-exec-arg
- "/etc/cron.daily/find.notslocate" fork-exec-arg
- "/etc/cron.daily/logrotate" fork-exec-arg
- "/etc/cron.daily/man-db" fork-exec-arg
- "/etc/cron.daily/ntp-server" fork-exec-arg
- "/etc/cron.daily/slocate" fork-exec-arg
- "/etc/cron.daily/standard" fork-exec-arg
- "/etc/cron.daily/sysklogd" fork-exec-arg
- "/etc/cron.daily/tetex-bin" fork-exec-arg
-] cron-jobs-daily set-global
-
-[
- "/etc/cron.weekly/cvs" fork-exec-arg
- "/etc/cron.weekly/man-db" fork-exec-arg
- "/etc/cron.weekly/ntp-server" fork-exec-arg
- "/etc/cron.weekly/popularity-contest" fork-exec-arg
- "/etc/cron.weekly/sysklogd" fork-exec-arg
-] cron-jobs-weekly set-global
-
-[
- "/etc/cron.monthly/scrollkeeper" fork-exec-arg
- "/etc/cron.monthly/standard" fork-exec-arg
-] cron-jobs-monthly set-global
\ No newline at end of file
+++ /dev/null
-
-USING: kernel parser namespaces threads arrays sequences unix unix.process
- bake ;
-
-IN: raptor
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: boot-hook
-SYMBOL: reboot-hook
-SYMBOL: shutdown-hook
-SYMBOL: networking-hook
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: reload-raptor-config ( -- )
- "/etc/raptor/config.factor" run-file
- "/etc/raptor/cronjobs.factor" run-file ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: fork-exec-wait ( pathname args -- )
- fork dup 0 = [ drop exec drop ] [ 2nip wait-for-pid drop ] if ;
-
-: fork-exec-args-wait ( args -- ) [ first ] [ ] bi fork-exec-wait ;
-
-: fork-exec-arg ( arg -- ) 1array [ fork-exec-args-wait ] curry in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: forever ( quot -- ) [ call ] [ forever ] bi ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start-service ( name -- ) "/etc/init.d/" " start" surround system drop ;
-: stop-service ( name -- ) "/etc/init.d/" " stop" surround system drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: getty ( tty -- ) `{ "/sbin/getty" "38400" , } fork-exec-args-wait ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: io io.files io.streams.lines io.streams.plain io.streams.duplex
- listener io.encodings.utf8 ;
-
-: tty-listener ( tty -- )
- dup utf8 <file-reader> [
- swap utf8 <file-writer> [
- <duplex-stream> [
- listener
- ] with-stream
- ] with-disposal
- ] with-disposal ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: unix.linux.swap unix.linux.fs ;
-
-SYMBOL: root-device
-SYMBOL: swap-devices
-
-: activate-swap ( -- ) swap-devices get [ 0 swapon drop ] each ;
-
-: mount-root ( -- ) root-device get "/" "ext3" MS_REMOUNT f mount drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start-networking ( -- ) networking-hook get call ;
-
-: set-hostname ( name -- ) `{ "/bin/hostname" , } fork-exec-args-wait ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: boot ( -- ) boot-hook get call ;
-: reboot ( -- ) reboot-hook get call ;
-: shutdown ( -- ) shutdown-hook get call ;
-
-MAIN: boot
-
+++ /dev/null
-
-Raptor Linux
-
-*** Introduction ***
-
-Raptor Linux is a mod of Ubuntu 6.06 (Dapper Drake)
-
-This is unlikely to work on another version of Ubuntu, much less
-another Linux distribution.
-
-*** Features ***
-
- * /sbin/init is replaced with Factor
- * Virtual terminals managed by Factor
- * Listeners run on virtual terminals
- * Native support for static ip networking
- * Crontab replacement
-
-*** Install ***
-
- # mkdir -v /etc/raptor
-
- # cp -v /scratch/factor/extra/raptor/{config,cronjobs}.factor /etc/raptor
-
- ( scratchpad ) USE: raptor
- ( scratchpad ) reload-raptor-config
- ( scratchpad ) save
-
- # mv -v /sbin/{init,init.orig}
-
- # cp -v /scratch/factor/factor /sbin/init
-
- # cp -v /scratch/factor/factor.image /sbin/init.image
-
-*** Filesystems ***
-
- # emacs /etc/raptor/config.factor
-
-Edit the root-device and swap-devices variables.
-
-*** Static IP networking ***
-
-If you use a static IP in your network then Factor can take care of
-networking.
-
- # emacs /etc/raptor/config.factor
-
- (change the settings accordingly)
-
-The udev system has a hook to bring up ethernet interfaces when they
-are detected. Let's remove this hook since we'll be bringing up the
-interface. Actually, we'll move it, not delete it.
-
- # mv -v /etc/udev/rules.d/85-ifupdown.rules /root
-
-*** DHCP networking ***
-
-If you're using dhcp then we'll fall back on what Ubuntu offers. In
-your config.factor change the line :
-
- start-networking
-
-to
-
- "loopback" start-service
- "networking" start-service
-
-Add these to your reboot-hook and shutdown-hook :
-
- "loopback" stop-service
- "networking" stop-service
-
-*** Editing the hooks ***
-
-The items in boot-hook correspond to the things in '/etc/rcS.d' and
-'/etc/rc2.d'. Feel free to add and remove items from that hook. For
-example, I removed the printer services. I also removed other things
-that I didn't feel were necessary on my system.
-
-Look for the line with the call to 'set-hostname' and edit it appropriately.
-
-*** Grub ***
-
-Edit your '/boot/grub/menu.lst'. Basically, copy and paste your
-current good entry. My default entry is this:
-
-title Ubuntu, kernel 2.6.15-28-686
-root (hd0,0)
-kernel /boot/vmlinuz-2.6.15-28-686 root=/dev/hda1 ro quiet splash
-initrd /boot/initrd.img-2.6.15-28-686
-savedefault
-boot
-
-I pasted a copy above it and edited it to look like this:
-
-title Raptor, kernel 2.6.15-28-686
-root (hd0,0)
-kernel /boot/vmlinuz-2.6.15-28-686 root=/dev/hda1 ro quiet -run=ubuntu.dapper.boot
-initrd /boot/initrd.img-2.6.15-28-686
-savedefault
-boot
-
-* Note that I removed the 'splash' kernel option
-
-* Note the '-run=ubuntu.dapper.boot' option. Unfortunately, this isn't
- working yet...
-
-*** Boot ***
-
-Reboot or turn on your computer. Eventually, hopefully, you'll be at a
-Factor prompt. Boot your system:
-
- ( scratchpad ) boot
-
-You'll probably be prompted to select a vocab. Select 'raptor'.
-
-*** Now what ***
-
-The virtual consoles are allocated like so:
-
- 1 - Main listener console
- 2 - listener
- 3 - listener
- 4 - listener
- 5 - getty
- 6 - getty
-
-So you're next step might be to alt-f5, login, and run startx.
-
-*** Join the fun ***
-
-Take a loot at what happens during run levels S and 2. Implement a
-Factor version of something. Let me know about it.
-
+++ /dev/null
-unportable
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel parser math quotations namespaces sequences macros fry ;
+
+IN: rewrite-closures
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: [set-parameters] ( seq -- quot ) reverse [ [ set ] curry ] map concat ;
+
+MACRO: set-parameters ( seq -- quot ) [set-parameters] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: parametric-quot ( parameters quot -- quot ) '[ _ set-parameters _ call ] ;
+
+: scoped-quot ( quot -- quot ) '[ _ with-scope ] ;
+
+: closed-quot ( quot -- quot )
+ namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: lambda ( parameters quot -- quot ) parametric-quot scoped-quot closed-quot ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: C[ \ ] [ >quotation ] parse-literal \ closed-quot parsed ; parsing
\ No newline at end of file
--- /dev/null
+Closures implemented via quotation rewriting
--- /dev/null
+extensions
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: alien.syntax ;
-
-IN: unix.linux.route
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-C-STRUCT: struct-rtentry
- { "ulong" "rt_pad1" }
- { "struct-sockaddr" "rt_dst" }
- { "struct-sockaddr" "rt_gateway" }
- { "struct-sockaddr" "rt_genmask" }
- { "ushort" "rt_flags" }
- { "short" "rt_pad2" }
- { "ulong" "rt_pad3" }
- { "uchar" "rt_tos" }
- { "uchar" "rt_class" }
- { "short" "rt_pad4" }
- { "short" "rt_metric" }
- { "char*" "rt_dev" }
- { "ulong" "rt_mtu" }
- { "ulong" "rt_window" }
- { "ushort" "rt_irtt" } ;
-
-: RTF_UP HEX: 0001 ; ! Route usable.
-: RTF_GATEWAY HEX: 0002 ; ! Destination is a gateway.
-
-: RTF_HOST HEX: 0004 ; ! Host entry (net otherwise).
-: RTF_REINSTATE HEX: 0008 ; ! Reinstate route after timeout.
-: RTF_DYNAMIC HEX: 0010 ; ! Created dyn. (by redirect).
-: RTF_MODIFIED HEX: 0020 ; ! Modified dyn. (by redirect).
-: RTF_MTU HEX: 0040 ; ! Specific MTU for this route.
-: RTF_MSS RTF_MTU ; ! Compatibility.
-: RTF_WINDOW HEX: 0080 ; ! Per route window clamping.
-: RTF_IRTT HEX: 0100 ; ! Initial round trip time.
-: RTF_REJECT HEX: 0200 ; ! Reject route.
-: RTF_STATIC HEX: 0400 ; ! Manually injected route.
-: RTF_XRESOLVE HEX: 0800 ; ! External resolver.
-: RTF_NOFORWARD HEX: 1000 ; ! Forwarding inhibited.
-: RTF_THROW HEX: 2000 ; ! Go to next class.
-: RTF_NOPMTUDISC HEX: 4000 ; ! Do not send packets with DF.
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: kernel alien.c-types io.sockets
- unix unix.linux.sockios ;
-
-: route ( dst gateway genmask flags -- )
- >r >r >r >r
- "struct-rtentry" <c-object>
- r> 0 <inet4> make-sockaddr over set-struct-rtentry-rt_dst
- r> 0 <inet4> make-sockaddr over set-struct-rtentry-rt_gateway
- r> 0 <inet4> make-sockaddr over set-struct-rtentry-rt_genmask
- r> over set-struct-rtentry-rt_flags
- AF_INET SOCK_DGRAM 0 socket SIOCADDRT rot ioctl drop ;
+++ /dev/null
-unportable
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces vars ;
+
+IN: self
+
+VAR: self
+
+: with-self ( quot obj -- ) [ >self call ] with-scope ;
+
+: save-self ( quot -- ) self> [ self> clone >self call ] dip >self ;
--- /dev/null
+
+USING: kernel words lexer parser sequences accessors self ;
+
+IN: self.slots
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: define-self-slot-reader ( slot -- )
+ [ "->" append current-vocab create dup set-word ]
+ [ ">>" append search [ self> ] swap suffix ] bi
+ (( -- value )) define-declared ;
+
+: define-self-slot-writer ( slot -- )
+ [ "->" prepend current-vocab create dup set-word ]
+ [ ">>" prepend search [ self> swap ] swap suffix [ drop ] append ] bi
+ (( value -- )) define-declared ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: define-self-slot-accessors ( class -- )
+ "slots" word-prop
+ [ name>> ] map
+ [ [ define-self-slot-reader ] [ define-self-slot-writer ] bi ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: SELF-SLOTS: scan-word define-self-slot-accessors ; parsing
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
-Doug Coleman
+++ /dev/null
-USING: help.syntax help.markup kernel prettyprint sequences\r
-quotations math ;\r
-IN: sequences.lib\r
-\r
-HELP: map-withn\r
-{ $values { "seq" sequence } { "quot" quotation } { "n" number } { "newseq" sequence } }\r
-{ $description "A generalisation of " { $link map } ". The first " { $snippet "n" } " items after the quotation will be "\r
-"passed to the quotation given to map-withn for each element in the sequence."\r
-} \r
-{ $examples\r
- { $example "USING: math sequences.lib prettyprint ;" "1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn .s" "{ 16 17 18 19 20 }" }\r
-}\r
-{ $see-also each-withn } ;\r
-\r
-HELP: each-withn\r
-{ $values { "seq" sequence } { "quot" quotation } { "n" number } }\r
-{ $description "A generalisation of " { $link each } ". The first " { $snippet "n" } " items after the quotation will be "\r
-"passed to the quotation given to each-withn for each element in the sequence."\r
-} \r
-{ $see-also map-withn } ;\r
-\r
-HELP: randomize\r
-{ $values { "seq" sequence } { "seq'" sequence } }\r
-{ $description "Shuffle the elements in the sequence randomly, returning the new sequence." } ;\r
-\r
-HELP: enumerate\r
-{ $values { "seq" sequence } { "seq'" sequence } }\r
-{ $description "Returns a new sequence where each element is an array of { index, value }" } ;\r
-\r
+++ /dev/null
-USING: arrays kernel sequences sequences.lib math math.functions math.ranges
- tools.test strings ;
-IN: sequences.lib.tests
-
-[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
-{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
-
-[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
-{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
-{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
-[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
-
-[ 10 ] [ { 1 2 3 4 } [ + ] reduce* ] unit-test
-[ 24 ] [ { 1 2 3 4 } [ * ] reduce* ] unit-test
-
-[ -4 ] [ 1 -4 [ abs ] higher ] unit-test
-[ 1 ] [ 1 -4 [ abs ] lower ] unit-test
-
-[ { 1 2 3 4 } ] [ { { 1 2 3 4 } { 1 2 3 } } longest ] unit-test
-[ { 1 2 3 4 } ] [ { { 1 2 3 } { 1 2 3 4 } } longest ] unit-test
-
-[ { 1 2 3 } ] [ { { 1 2 3 4 } { 1 2 3 } } shortest ] unit-test
-[ { 1 2 3 } ] [ { { 1 2 3 } { 1 2 3 4 } } shortest ] unit-test
-
-[ 3 ] [ 1 3 bigger ] unit-test
-[ 1 ] [ 1 3 smaller ] unit-test
-
-[ "abd" ] [ "abc" "abd" bigger ] unit-test
-[ "abc" ] [ "abc" "abd" smaller ] unit-test
-
-[ "abe" ] [ { "abc" "abd" "abe" } biggest ] unit-test
-[ "abc" ] [ { "abc" "abd" "abe" } smallest ] unit-test
-
-[ 1 3 ] [ { 1 2 3 } minmax ] unit-test
-[ -11 -9 ] [ { -11 -10 -9 } minmax ] unit-test
-[ -1/0. 1/0. ] [ { -1/0. 1/0. -11 -10 -9 } minmax ] unit-test
-
-[ { { 1 } { -1 5 } { 2 4 } } ]
-[ { 1 -1 5 2 4 } [ < ] monotonic-split [ >array ] map ] unit-test
-[ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ]
-[ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test
-
-[ { 1 9 25 } ] [ { 1 3 5 6 } [ sq ] [ even? ] map-until ] unit-test
-[ { 2 4 } ] [ { 2 4 1 3 } [ even? ] take-while ] unit-test
-
-[ { { 0 0 } { 1 0 } { 0 1 } { 1 1 } } ] [ 2 2 exact-strings ] unit-test
-[ t ] [ "ab" 4 strings [ >string ] map "abab" swap member? ] unit-test
-[ { { } { 1 } { 2 } { 1 2 } } ] [ { 1 2 } power-set ] unit-test
-
-[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
-{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
-{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
-[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
-{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
-[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
-
-[ { { 0 1 } { 1 2 } { 2 3 } } ] [ { 1 2 3 } enumerate ] unit-test
-
+++ /dev/null
-! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
-! Eduardo Cavazos, Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.lib kernel sequences math namespaces make
-assocs random sequences.private shuffle math.functions arrays
-math.parser math.private sorting strings ascii macros assocs.lib
-quotations hashtables math.order locals generalizations
-math.ranges random fry ;
-IN: sequences.lib
-
-: each-withn ( seq quot n -- ) nwith each ; inline
-
-: each-with ( seq quot -- ) with each ; inline
-
-: each-with2 ( obj obj list quot -- ) 2 each-withn ; inline
-
-: map-withn ( seq quot n -- newseq ) nwith map ; inline
-
-: map-with ( seq quot -- ) with map ; inline
-
-: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: each-percent ( seq quot -- )
- [
- dup length
- dup [ / ] curry
- [ 1+ ] prepose
- ] dip compose
- 2each ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: reduce* ( seq quot -- result ) [ ] swap map-reduce ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: higher ( a b quot -- c ) [ compare +gt+ eq? ] curry most ; inline
-
-: lower ( a b quot -- c ) [ compare +lt+ eq? ] curry most ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: longer ( a b -- c ) [ length ] higher ;
-
-: shorter ( a b -- c ) [ length ] lower ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: longest ( seq -- item ) [ longer ] reduce* ;
-
-: shortest ( seq -- item ) [ shorter ] reduce* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bigger ( a b -- c ) [ ] higher ;
-
-: smaller ( a b -- c ) [ ] lower ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: biggest ( seq -- item ) [ bigger ] reduce* ;
-
-: smallest ( seq -- item ) [ smaller ] reduce* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: minmax ( seq -- min max )
- #! find the min and max of a seq in one pass
- 1/0. -1/0. rot [ tuck max [ min ] dip ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ,, ( obj -- ) building get peek push ;
-: v, ( -- ) V{ } clone , ;
-: ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
-
-: (monotonic-split) ( seq quot -- newseq )
- [
- [ dup unclip suffix ] dip
- v, [ pick ,, call [ v, ] unless ] curry 2each ,v
- ] { } make ;
-
-: monotonic-split ( seq quot -- newseq )
- over empty? [ 2drop { } ] [ (monotonic-split) ] if ;
-
-ERROR: element-not-found ;
-: split-around ( seq quot -- before elem after )
- dupd find over [ element-not-found ] unless
- [ cut rest ] dip swap ; inline
-
-: map-until ( seq quot pred -- newseq )
- '[ [ @ dup @ [ drop t ] [ , f ] if ] find 2drop ] { } make ;
-
-: take-while ( seq quot -- newseq )
- [ not ] compose
- [ find drop [ head-slice ] when* ] curry
- [ dup ] prepose keep like ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<PRIVATE
-: translate-string ( n alphabet out-len -- seq )
- [ drop /mod ] with map nip ;
-
-: map-alphabet ( alphabet seq[seq] -- seq[seq] )
- [ [ swap nth ] with map ] with map ;
-
-: exact-number-strings ( n out-len -- seqs )
- [ ^ ] 2keep [ translate-string ] 2curry map ;
-
-: number-strings ( n max-length -- seqs )
- 1+ [ exact-number-strings ] with map concat ;
-PRIVATE>
-
-: exact-strings ( alphabet length -- seqs )
- [ dup length ] dip exact-number-strings map-alphabet ;
-
-: strings ( alphabet length -- seqs )
- [ dup length ] dip number-strings map-alphabet ;
-
-: switches ( seq1 seq -- subseq )
- ! seq1 is a sequence of ones and zeroes
- [ [ length ] keep [ nth 1 = ] curry filter ] dip
- [ nth ] curry { } map-as ;
-
-: power-set ( seq -- subsets )
- 2 over length exact-number-strings swap [ switches ] curry map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<PRIVATE
-: (attempt-each-integer) ( i n quot -- result )
- [
- iterate-step roll
- [ 3nip ] [ iterate-next (attempt-each-integer) ] if*
- ] [ 3drop f ] if-iterate? ; inline recursive
-PRIVATE>
-
-: attempt-each ( seq quot -- result )
- (each) iterate-prep (attempt-each-integer) ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: randomize ( seq -- seq' )
- dup length 1 (a,b] [ dup random pick exchange ] each ;
-
-: enumerate ( seq -- seq' ) <enum> >alist ;
+++ /dev/null
-Non-core sequence words
+++ /dev/null
-collections
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-IN: unix.linux.sockios
-
-! Imported from linux-headers-2.6.15-28-686 on Ubuntu 6.06
-
-! Routing table calls
-: SIOCADDRT HEX: 890B ; ! add routing table entry
-: SIOCDELRT HEX: 890C ; ! delete routing table entry
-: SIOCRTMSG HEX: 890D ; ! call to routing system
-
-! Socket configuration controls
-
-: SIOCGIFNAME HEX: 8910 ; ! get iface name
-: SIOCSIFLINK HEX: 8911 ; ! set iface channel
-: SIOCGIFCONF HEX: 8912 ; ! get iface list
-: SIOCGIFFLAGS HEX: 8913 ; ! get flags
-: SIOCSIFFLAGS HEX: 8914 ; ! set flags
-: SIOCGIFADDR HEX: 8915 ; ! get PA address
-: SIOCSIFADDR HEX: 8916 ; ! set PA address
-: SIOCGIFDSTADDR HEX: 8917 ; ! get remote PA address
-: SIOCSIFDSTADDR HEX: 8918 ; ! set remote PA address
-: SIOCGIFBRDADDR HEX: 8919 ; ! get broadcast PA address
-: SIOCSIFBRDADDR HEX: 891a ; ! set broadcast PA address
-: SIOCGIFNETMASK HEX: 891b ; ! get network PA mask
-: SIOCSIFNETMASK HEX: 891c ; ! set network PA mask
-: SIOCGIFMETRIC HEX: 891d ; ! get metric
-: SIOCSIFMETRIC HEX: 891e ; ! set metric
-: SIOCGIFMEM HEX: 891f ; ! get memory address (BSD)
-: SIOCSIFMEM HEX: 8920 ; ! set memory address (BSD)
-: SIOCGIFMTU HEX: 8921 ; ! get MTU size
-: SIOCSIFMTU HEX: 8922 ; ! set MTU size
-: SIOCSIFNAME HEX: 8923 ; ! set interface name
-: SIOCSIFHWADDR HEX: 8924 ; ! set hardware address
-: SIOCGIFENCAP HEX: 8925 ; ! get/set encapsulations
-: SIOCSIFENCAP HEX: 8926 ;
-: SIOCGIFHWADDR HEX: 8927 ; ! Get hardware address
-: SIOCGIFSLAVE HEX: 8929 ; ! Driver slaving support
-: SIOCSIFSLAVE HEX: 8930 ;
-: SIOCADDMULTI HEX: 8931 ; ! Multicast address lists
-: SIOCDELMULTI HEX: 8932 ;
-: SIOCGIFINDEX HEX: 8933 ; ! name -> if_index mapping
-: SIOGIFINDEX SIOCGIFINDEX ; ! misprint compatibility :-)
-: SIOCSIFPFLAGS HEX: 8934 ; ! set/get extended flags set
-: SIOCGIFPFLAGS HEX: 8935 ;
-: SIOCDIFADDR HEX: 8936 ; ! delete PA address
-: SIOCSIFHWBROADCAST HEX: 8937 ; ! set hardware broadcast addr
-: SIOCGIFCOUNT HEX: 8938 ; ! get number of devices
-
-: SIOCGIFBR HEX: 8940 ; ! Bridging support
-: SIOCSIFBR HEX: 8941 ; ! Set bridging options
-
-: SIOCGIFTXQLEN HEX: 8942 ; ! Get the tx queue length
-: SIOCSIFTXQLEN HEX: 8943 ; ! Set the tx queue length
-
-: SIOCGIFDIVERT HEX: 8944 ; ! Frame diversion support
-: SIOCSIFDIVERT HEX: 8945 ; ! Set frame diversion options
-
-: SIOCETHTOOL HEX: 8946 ; ! Ethtool interface
-
-: SIOCGMIIPHY HEX: 8947 ; ! Get address of MII PHY in use
-: SIOCGMIIREG HEX: 8948 ; ! Read MII PHY register.
-: SIOCSMIIREG HEX: 8949 ; ! Write MII PHY register.
-
-: SIOCWANDEV HEX: 894A ; ! get/set netdev parameters
+++ /dev/null
-unportable
--- /dev/null
+
+USING: kernel lexer parser words quotations compiler.units ;
+
+IN: sto
+
+! Use 'sto' to bind a value on the stack to a word.
+!
+! Example:
+!
+! 10 sto A
+
+: sto
+ \ 1quotation parsed
+ scan
+ current-vocab create
+ dup set-word
+ literalize parsed
+ \ swap parsed
+ [ define ] parsed
+ \ with-compilation-unit parsed ; parsing
+++ /dev/null
-USING: kernel sequences strings.lib tools.test ;
-IN: temporary
-
-[ "abcdefghijklmnopqrstuvwxyz" ] [ lower-alpha-chars "" like ] unit-test
-[ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test
-[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test
-[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-chars "" like ] unit-test
-[ t ] [ 100 [ random-alphanumeric-char ] replicate alphanumeric-chars [ member? ] curry all? ] unit-test
+++ /dev/null
-USING: math math.ranges arrays sequences kernel random splitting
-strings unicode.case ;
-IN: strings.lib
-
-: >Upper ( str -- str )
- dup empty? [ unclip ch>upper prefix ] unless ;
-
-: >Upper-dashes ( str -- str )
- "-" split [ >Upper ] map "-" join ;
-
-: lower-alpha-chars ( -- seq )
- CHAR: a CHAR: z [a,b] ;
-
-: upper-alpha-chars ( -- seq )
- CHAR: A CHAR: Z [a,b] ;
-
-: numeric-chars ( -- seq )
- CHAR: 0 CHAR: 9 [a,b] ;
-
-: alpha-chars ( -- seq )
- lower-alpha-chars upper-alpha-chars append ;
-
-: alphanumeric-chars ( -- seq )
- alpha-chars numeric-chars append ;
-
-: random-alpha-char ( -- ch )
- alpha-chars random ;
-
-: random-alphanumeric-char ( -- ch )
- alphanumeric-chars random ;
-
-: random-alphanumeric-string ( length -- str )
- [ random-alphanumeric-char ] "" replicate-as ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: alien.syntax ;
-
-IN: unix.linux.swap
-
-: SWAP_FLAG_PREFER HEX: 8000 ; ! Set if swap priority is specified.
-: SWAP_FLAG_PRIO_MASK HEX: 7fff ;
-: SWAP_FLAG_PRIO_SHIFT 0 ;
-
-FUNCTION: int swapon ( char* path, int flags ) ;
-
-FUNCTION: int swapoff ( char* path ) ;
\ No newline at end of file
+++ /dev/null
-unportable
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences math x11.xlib
- mortar slot-accessors x ;
-
-IN: x.font
-
-SYMBOL: <font>
-
-<font> { "dpy" "name" "id" "struct" } accessors define-independent-class
-
-<font> "create" !( name <font> -- font ) [
-new-empty swap >>name dpy get >>dpy
-dpy get $ptr over $name XLoadQueryFont >>struct
-dup $struct XFontStruct-fid >>id
-] add-class-method
-
-<font> {
-
-"ascent" !( font -- ascent ) [ $struct XFontStruct-ascent ]
-
-"descent" !( font -- ascent ) [ $struct XFontStruct-descent ]
-
-"height" !( font -- ascent ) [ dup <- ascent swap <- descent + ]
-
-"text-width" !( font string -- width ) [ >r $struct r> dup length XTextWidth ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays x11.xlib mortar mortar.sugar
- slot-accessors x x.font ;
-
-IN: x.gc
-
-SYMBOL: <gc>
-
-<gc> { "dpy" "ptr" "font" } accessors define-independent-class
-
-<gc> "create" !( <gc> -- gc ) [
-new-empty dpy get >>dpy
-dpy get $ptr dpy get $default-root $id 0 f XCreateGC >>ptr
-"6x13" <font> new* >>font
-] add-class-method
-
-<gc> {
-
-"set-subwindow-mode" !( gc mode -- gc )
- [ >r dup $dpy $ptr over $ptr r> XSetSubwindowMode drop ]
-
-"set-function" !( gc function -- gc )
- [ >r dup $dpy $ptr over $ptr r> XSetFunction drop ]
-
-"set-foreground" !( gc foreground -- gc )
- [ >r dup $dpy $ptr over $ptr r> lookup-color XSetForeground drop ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-USING: kernel strings assocs sequences math ;
-
-IN: x.keysym-table
-
-: keysym-table ( -- table )
-H{ { HEX: FF08 "BACKSPACE" }
- { HEX: FF09 "TAB" }
- { HEX: FF0D "RETURN" }
- { HEX: FF8D "ENTER" }
- { HEX: FF1B "ESCAPE" }
- { 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" }
- { HEX: FFC7 "F10" }
- { HEX: FFC8 "F11" }
- { HEX: FFC9 "F12" }
- { HEX: FFE1 "LEFT-SHIFT" }
- { HEX: FFE2 "RIGHT-SHIFT" }
- { HEX: FFE3 "LEFT-CONTROL" }
- { HEX: FFE4 "RIGHT-CONTROL" }
- { HEX: FFE5 "CAPSLOCK" }
- { HEX: FFE9 "LEFT-ALT" }
- { HEX: FFEA "RIGHT-ALT" }
-} ;
-
-: keysym>name ( keysym -- name )
-dup keysym-table at dup [ nip ] [ drop 1string ] if ;
-
-: name>keysym ( name -- keysym ) keysym-table value-at ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel arrays math.vectors mortar mortar.sugar x.gc slot-accessors geom.pos ;
-
-IN: x.pen
-
-SYMBOL: <pen>
-
-<pen> <pos> { "window" "gc" } accessors define-simple-class
-
-<pen> "create" !( window <pen> -- pen )
-[ new-empty swap >>window <gc> new* >>gc 0 0 2array >>pos ]
-add-class-method
-
-<pen> {
-
-"line-to" ! ( pen point -- pen )
- [ 2dup >r dup $window swap dup $gc swap $pos r> <---- draw-line >>pos ]
-
-"line-by" ! ( pen offset -- pen )
- [ 2dup >r dup $window swap dup $gc swap $pos dup r> v+ <---- draw-line
- <-- move-by ]
-
-"draw-string" ! ( pen string -- pen )
- [ >r dup dup $window swap dup $gc swap $pos r> <---- draw-string ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel combinators math x11.xlib
- mortar mortar.sugar slot-accessors x.gc x.widgets.label ;
-
-IN: x.widgets.button
-
-SYMBOL: <button>
-
-<button>
- <label>
- { "action-1" "action-2" "action-3" } accessors
-define-simple-class
-
-<button> "create" !( <button> -- button ) [
-new-empty
-<gc> new* >>gc ExposureMask ButtonPressMask bitor >>mask <- init-widget
-] add-class-method
-
-<button> "handle-button-press" !( event button -- ) [
-{ { [ over XButtonEvent-button Button1 = ] [ nip $action-1 call ] }
- { [ over XButtonEvent-button Button2 = ] [ nip $action-2 call ] }
- { [ over XButtonEvent-button Button3 = ] [ nip $action-3 call ] } }
-cond
-] add-method
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel strings arrays sequences sequences.lib math x11.xlib
- mortar mortar.sugar slot-accessors x x.pen x.widgets ;
-
-IN: x.widgets.keymenu
-
-SYMBOL: <keymenu>
-
-<keymenu> <widget> { "items" "pen" } accessors define-simple-class
-
-<keymenu> "create" !( <keymenu> -- keymenu )
- [ new-empty <- keymenu-init ]
-add-class-method
-
-: numbers-and-letters ( -- seq )
-"1234567890abcdefghijklmnopqrstuvwxyz" [ 1string ] { } map-as ;
-
-<keymenu> {
-
-"keymenu-init" !( keymenu -- keymenu ) [
- dup <pen> new* >>pen
- ExposureMask KeyPressMask bitor >>mask
- <- init-widget
-]
-
-"item-labels" !( keymenu -- labels ) [ $items [ first ] map ]
-
-"item-actions" !( keymenu -- actions ) [ $items [ second ] map ]
-
-"keymenu-labels" !( keymenu -- seq )
-[ numbers-and-letters swap <- item-labels [ " - " swap 3append ] 2map ]
-
-"reset-pen" !( keymenu -- keymenu ) [
- dup $pen
- 1 <-- set-x
- dup $gc $font <- ascent 1+ <-- set-y
- drop ]
-
-"handle-expose" !( event keymenu -- ) [
- nip
- <- reset-pen
- dup $pen swap <- keymenu-labels
- [ <-- draw-string dup $gc $font <- height <-- move-by-y ] each drop ]
-
-"keymenu-handle-key-press" !( event keymenu -- ) [
- swap 0 key-event-to-string numbers-and-letters index
- [ swap <- item-actions ?nth [ call ] when* ]
- [ drop ]
- if* ]
-
-"handle-key-press" !( event keymenu -- ) [ <- keymenu-handle-key-press ]
-
-"calc-height" !( keymenu -- height )
- [ dup $items length swap $pen $gc $font <- height * ]
-
-"calc-width" !( keymenu -- width )
- [ dup $pen $gc $font
- swap $items [ first " " append ] map
- dup empty? [ drop "" ] [ longest ] if
- <-- text-width ]
-
-"calc-size" !( keymenu -- size )
- [ dup <- calc-width swap <- calc-height 2array ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel x11.xlib mortar mortar.sugar slot-accessors x.gc x.widgets ;
-
-IN: x.widgets.label
-
-SYMBOL: <label>
-
-<label> <widget> { "gc" "text" } accessors define-simple-class
-
-<label> "create" !( text <label> -- label ) [
-new-empty swap >>text <gc> new* >>gc ExposureMask >>mask <- init-widget
-] add-class-method
-
-<label> "handle-expose" !( event label -- ) [
- nip <- clear dup $gc { 20 20 } pick $text <---- draw-string
-] add-method
+++ /dev/null
-
-USING: kernel io namespaces arrays sequences combinators math x11.xlib
- mortar slot-accessors x ;
-
-IN: x.widgets
-
-SYMBOL: <widget>
-
-<widget> <window> { "mask" } accessors define-simple-class
-
-<widget> {
-
-"init-widget" !( widget -- widget )
- [ <- init-window <- add-to-window-table dup $mask <-- select-input ]
-
-"add-to-window-table" !( window -- window )
- [ dup $dpy over <-- add-to-window-table ]
-
-"remove-from-window-table" !( window -- window )
- [ dup $dpy over <-- remove-from-window-table ]
-
-"handle-event" !( event widget -- ) [
- over XAnyEvent-type
- { { [ dup Expose = ] [ drop <- handle-expose ] }
- { [ dup KeyPress = ] [ drop <- handle-key-press ] }
- { [ dup ButtonPress = ] [ drop <- handle-button-press ] }
- { [ dup EnterNotify = ] [ drop <- handle-enter-window ] }
- { [ dup DestroyNotify = ] [ drop <- handle-destroy-window ] }
- { [ dup MapRequest = ] [ drop <- handle-map-request ] }
- { [ dup MapNotify = ] [ drop <- handle-map ] }
- { [ dup ConfigureRequest = ] [ drop <- handle-configure-request ] }
- { [ dup UnmapNotify = ] [ drop <- handle-unmap ] }
- { [ dup PropertyNotify = ] [ drop <- handle-property ] }
- { [ t ] [ "handle-event :: ignoring event"
- print flush 3drop ] }
- } cond ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel io namespaces arrays sequences
- x11.xlib mortar slot-accessors x x.widgets ;
-
-IN: x.widgets.wm.child
-
-SYMBOL: <wm-child>
-
-<wm-child> <widget> { } define-simple-class
-
-<wm-child> "create" !( id <wm-child> -- wm-child ) [
- new-empty swap >>id dpy get >>dpy PropertyChangeMask >>mask
- <- add-to-save-set
- 0 <-- set-border-width
- <- add-to-window-table
- dup $mask <-- select-input
-] add-class-method
-
-<wm-child> "handle-property" !( event wm-child -- ) [
- drop
- "child handle-property :: atom name = " write
- XPropertyEvent-atom get-atom-name print flush
-] add-method
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces arrays sequences combinators math.vectors
- x11.xlib x11.constants
- mortar slot-accessors x x.gc geom.rect ;
-
-IN: x.widgets.wm.frame.drag
-
-SYMBOL: <wm-frame-drag>
-
-<wm-frame-drag>
- { "dpy" "gc" "frame" "event" "push" "posn" } accessors
-define-independent-class
-
-<wm-frame-drag> {
-
-"next-event" !( wfdm -- wfdm ) [ dup $dpy over $event <-- next-event 2drop ]
-
-"event-type" !( wfdm -- wfdm event-type ) [ dup $event XAnyEvent-type ]
-
-"drag-offset" !( wfdm -- offset ) [ dup $posn swap $push v- ]
-
-"update-posn" !( wfd -- wfd ) [ dup $event XMotionEvent-root-position >>posn ]
-
-} add-methods
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel combinators namespaces math.vectors x11.xlib x11.constants
- mortar mortar.sugar slot-accessors x x.gc x.widgets.wm.frame.drag ;
-
-IN: x.widgets.wm.frame.drag.move
-
-SYMBOL: <wm-frame-drag-move>
-
-<wm-frame-drag-move> <wm-frame-drag> { } define-simple-class
-
-<wm-frame-drag-move> "create" !( event frame <wm-frame-drag-move> -- ) [
- new-empty swap >>frame swap >>event dup $frame $dpy >>dpy
-
- <gc> new*
- IncludeInferiors <-- set-subwindow-mode
- GXxor <-- set-function
- "white" <-- set-foreground
- >>gc
-
- dup $event XButtonEvent-root-position >>push
- dup $event XButtonEvent-root-position >>posn
- <- draw-move-outline
- <- loop
-] add-class-method
-
-<wm-frame-drag-move> {
-
-"move-outline" !( wfdm -- rect )
- [ dup $frame <- as-rect swap <- drag-offset <-- move-by ]
-
-"draw-move-outline" !( wfdm -- wfdm )
- [ dpy get $default-root over $gc pick <- move-outline <--- draw-rect ]
-
-"loop" !( wfdm -- wfdm ) [
- <- next-event
- { { [ <- event-type MotionNotify = ]
- [ <- draw-move-outline <- update-posn <- draw-move-outline <- loop ] }
- { [ <- event-type ButtonRelease = ]
- [ <- draw-move-outline
- dup $frame <- position over <- drag-offset v+ >r
- dup $frame r> <-- move drop
- dup $frame <- raise drop drop ] }
- { [ t ] [ <- loop ] } }
- cond ]
-
-} add-methods
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel combinators namespaces math.vectors x11.xlib x11.constants
- mortar mortar.sugar slot-accessors geom.rect x x.gc x.widgets.wm.frame.drag ;
-
-IN: x.widgets.wm.frame.drag.size
-
-SYMBOL: <wm-frame-drag-size>
-
-<wm-frame-drag-size> <wm-frame-drag> { } define-simple-class
-
-<wm-frame-drag-size> "create" !( event frame <wfds> -- ) [
- new-empty swap >>frame swap >>event
- dup $frame $dpy >>dpy
-
- <gc> new*
- IncludeInferiors <-- set-subwindow-mode
- GXxor <-- set-function
- "white" <-- set-foreground
- >>gc
-
- dup $event XButtonEvent-root-position >>push
- dup $event XButtonEvent-root-position >>posn
- <- draw-size-outline <- loop
-] add-class-method
-
-<wm-frame-drag-size> {
-
-"size-outline" !( wfds -- rect )
- [ dup $frame <- position swap $posn over v- <rect> new ]
-
-"draw-size-outline" !( wfdm -- wfdm )
- [ dup $dpy $default-root over $gc pick <- size-outline <--- draw-rect ]
-
-"loop" !( wfdm -- ) [
- <- next-event
- { { [ <- event-type MotionNotify = ]
- [ <- draw-size-outline <- update-posn <- draw-size-outline <- loop ] }
- { [ <- event-type ButtonRelease = ]
- [ <- draw-size-outline
- dup $frame over $posn pick $frame <- position v- <-- resize
- <- adjust-child drop ] }
- { [ t ] [ <- loop ] } }
- cond ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-
-USING: kernel io combinators namespaces quotations arrays sequences
- math math.vectors
- x11.xlib x11.constants
- mortar mortar.sugar slot-accessors
- geom.rect
- math.bitwise
- x x.gc x.widgets
- x.widgets.button
- x.widgets.wm.child
- x.widgets.wm.frame.drag.move
- x.widgets.wm.frame.drag.size ;
-
-IN: x.widgets.wm.frame
-
-SYMBOL: <wm-frame>
-
-<wm-frame> <widget> { "child" "gc" "last-state" } accessors define-simple-class
-
-<wm-frame> "create" !( id <wm-frame> -- wm-frame ) [
- new-empty
- swap <wm-child> new* >>child
- <gc> new* "white" <-- set-foreground >>gc
-
- {
- SubstructureRedirectMask
- ExposureMask
- ButtonPressMask
- ButtonReleaseMask
- ButtonMotionMask
- EnterWindowMask
- ! experimental masks
- SubstructureNotifyMask
- } flags
- >>mask
-
- <- init-widget
- "cornflowerblue" <-- set-background
- dup $child <- position <-- move
- dup $child over <-- reparent drop
- <- position-child
- <- fit-to-child
- <- make-frame-button
-
- <- map-subwindows
- <- map
-] add-class-method
-
-SYMBOL: WM_PROTOCOLS
-SYMBOL: WM_DELETE_WINDOW
-
-: init-atoms ( -- )
-"WM_PROTOCOLS" 0 intern-atom WM_PROTOCOLS set
-"WM_DELETE_WINDOW" 0 intern-atom WM_DELETE_WINDOW set ;
-
-<wm-frame> {
-
-"fit-to-child" !( wm-frame -- wm-frame )
- [ dup $child <- size { 10 20 } v+ <-- resize ]
-
-"position-child" !( wm-frame -- wm-frame )
- [ dup $child { 5 15 } <-- move drop ]
-
-"set-child-size" !( wm-frame size -- frame )
- [ >r dup $child r> <-- resize drop <- fit-to-child ]
-
-"set-child-width" !( wm-frame width -- frame )
- [ >r dup $child r> <- set-width drop <- fit-to-child ]
-
-"set-child-height" !( wm-frame height -- frame )
- [ >r dup $child r> <- set-height drop <- fit-to-child ]
-
-"adjust-child" !( wm-frame -- wm-frame )
- [ dup $child over <- size { 10 20 } v- <-- resize drop ]
-
-"update-title" !( wm-frame -- wm-frame )
- [ <- clear
- dup >r
- ! dup $gc { 5 1 } pick $child <- fetch-name <--- draw-string/top-left
- dup $gc { 5 11 } pick $child <- fetch-name <---- draw-string
- r> ]
-
-"delete-child" !( wm-frame -- wm-frame ) [
- dup $child WM_PROTOCOLS get WM_DELETE_WINDOW get <--- send-client-message
- drop ]
-
-"drag-move" !( event wm-frame -- ) [ <wm-frame-drag-move> new* ]
-
-"drag-size" !( event wm-frame -- ) [ <wm-frame-drag-size> new* ]
-
-"make-frame-button" !( frame -- frame ) [
-<button> new*
- over <-- reparent
- "" >>text
- over [ <- unmap drop ] curry >>action-1
- over [ <- delete-child drop ] curry >>action-3
- { 9 9 } <-- resize
- NorthEastGravity <-- set-gravity
- "white" <-- set-background
- over <- width 9 - 5 - 3 2array <-- move
- drop ]
-
-! !!!!!!!!!! Event handlers !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-"handle-enter-window" !( event wm-frame -- )
- [ nip $child RevertToPointerRoot CurrentTime <--- set-input-focus drop ]
-
-"handle-expose" !( event wm-frame -- ) [ nip <- clear <- update-title drop ]
-
-"handle-button-press" !( event wm-frame -- ) [
- over XButtonEvent-button
- { { [ dup Button1 = ] [ drop <- drag-move ] }
- { [ dup Button2 = ] [ drop <- drag-size ] }
- { [ t ] [ 3drop ] } }
- cond ]
-
-"handle-map" !( event wm-frame -- )
- [ "<wm-frame> handle-map :: ignoring values" print flush 2drop ]
-
-"handle-unmap" !( event wm-frame -- ) [ nip <- unmap drop ]
-
-"handle-destroy-window" !( event wm-frame -- ) [
- nip dup $child <- remove-from-window-table drop
- <- remove-from-window-table <- destroy ]
-
-"handle-configure-request" !( event frame -- ) [
- { { [ over dup CWX? swap CWY? and ]
- [ over XConfigureRequestEvent-position <-- move ] }
- { [ over CWX? ] [ over XConfigureRequestEvent-x <-- set-x ] }
- { [ over CWY? ] [ over XConfigureRequestEvent-y <-- set-y ] }
- { [ t ] [ "<wm-frame> handle-configure-request :: move not requested"
- print flush ] } }
- cond
-
- { { [ over dup CWWidth? swap CWHeight? and ]
- [ over XConfigureRequestEvent-size <-- set-child-size ] }
- { [ over CWWidth? ]
- [ over XConfigureRequestEvent-width <-- set-child-width ] }
- { [ over CWHeight? ]
- [ over XConfigureRequestEvent-height <-- set-child-height ] }
- { [ t ]
- [ "<wm-frame> handle-configure-request :: resize not requested"
- print flush ] } }
- cond
- 2drop ]
-
-} add-methods
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: wm-frame-maximize ( wm-frame -- wm-frame )
-<- save-state
-{ 0 0 } <-- move
-dup $dpy $default-root <- size
- <-- resize
-<- adjust-child
-<- raise ;
-
-: wm-frame-maximize-vertical ( wm-frame -- wm-frame )
-0 <-- set-y
-dup $dpy $default-root <- height
- <-- set-height
-<- adjust-child ;
-
-<wm-frame> "save-state" !( wm-frame -- wm-frame ) [
- dup <- position
- over <- size
- <rect> new
- >>last-state
-] add-method
-
-<wm-frame> "restore-state" !( wm-frame -- wm-frame ) [
- dup $last-state $pos <-- move
- dup $last-state $dim <-- resize
- <- adjust-child
-] add-method
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel x11.constants mortar mortar.sugar slot-accessors x.widgets.keymenu ;
-
-IN: x.widgets.wm.menu
-
-SYMBOL: <wm-menu>
-
-<wm-menu> <keymenu> { } define-simple-class
-
-<wm-menu> "create" !( <wm-menu> -- wm-menu )
- [ new-empty <- keymenu-init ]
-add-class-method
-
-<wm-menu> {
-
-"wm-menu-handle-key-press" !( event wm-menu -- )
- [ <- unmap <- keymenu-handle-key-press ]
-
-"handle-key-press" !( event wm-menu -- ) [ <- wm-menu-handle-key-press ]
-
-"wm-menu-popup" !( wm-menu -- wm-menu )
- [ <- map <- raise RevertToPointerRoot CurrentTime <--- set-input-focus ]
-
-"popup" !( wm-menu -- wm-menu ) [ <- wm-menu-popup ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel io combinators namespaces arrays assocs sequences math
- x11.xlib
- x11.constants
- vars mortar slot-accessors
- x x.keysym-table x.widgets x.widgets.wm.child x.widgets.wm.frame ;
-
-IN: x.widgets.wm.root
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: <wm-root>
-
-<wm-root>
- <widget>
- { "keymap" } accessors
-define-simple-class
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: wm-root
-
-: create-wm-root ( -- )
- <wm-root> new-empty
- dpy> >>dpy
- dpy> $default-root $id >>id
- SubstructureRedirectMask >>mask
- <- add-to-window-table
- SubstructureRedirectMask <-- select-input
- H{ } clone >>keymap
- >wm-root ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: find-in-table ( window -- object )
-dup >r $id dpy get $window-table at r> or ;
-
-: circulate-focus ( -- )
-dpy get $default-root <- children
-[ find-in-table ] map [ <- mapped? ] filter dup length 1 >
-[ reverse dup first <- lower drop
- second <- raise
- dup <wm-frame> is? [ $child ] [ ] if
- RevertToPointerRoot CurrentTime <--- set-input-focus drop ]
-[ drop ]
-if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: managed? ( id -- ? )
-dpy get $window-table values [ <wm-child> is? ] filter [ $id ] map member? ;
-
-: event>keyname ( event -- keyname ) lookup-keysym keysym>name ;
-
-: event>state-and-name ( event -- array )
-dup XKeyEvent-state swap event>keyname 2array ;
-
-: resolve-key-event ( keymap event -- item ) event>state-and-name swap at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<wm-root> {
-
-"handle-map-request" !( event wm-root -- ) [
- { { [ over XMapRequestEvent-window managed? ]
- [ "<wm-root> handle-map-request :: window already managed" print flush
- 2drop ] }
- { [ t ] [ drop XMapRequestEvent-window <wm-frame> <<- create drop ] } }
- cond ]
-
-"handle-unmap" !( event wm-root -- ) [ 2drop ]
-
-"handle-key-press" !( event wm-root -- )
- [ $keymap swap resolve-key-event call ]
-
-"grab-key" !( wm-root modifiers keyname -- wm-root modifiers keyname ) [
- 3dup name>keysym keysym-to-keycode spin
- False GrabModeAsync GrabModeAsync grab-key ]
-
-"set-key-action" !( wm-root modifiers keyname action -- wm-root ) [
- >r <--- grab-key r>
- -rot 2array pick $keymap set-at ]
-
-"handle-configure-request" !( event wm-root -- ) [
- $dpy over XConfigureRequestEvent-window <window> new ! event window
- { { [ over dup CWX? swap CWY? and ]
- [ over XConfigureRequestEvent-position <-- move ] }
- { [ over CWX? ] [ over XConfigureRequestEvent-x <-- set-x ] }
- { [ over CWY? ] [ over XConfigureRequestEvent-y <-- set-y ] }
- { [ t ] [ "<wm-root> handle-configure-request :: move not requested"
- print flush ] } }
- cond
-
- { { [ over dup CWWidth? swap CWHeight? and ]
- [ over XConfigureRequestEvent-size <-- resize ] }
- { [ over CWWidth? ] [ over XConfigureRequestEvent-width <-- set-width ] }
- { [ over CWHeight? ] [ over XConfigureRequestEvent-height <-- set-height ] }
- { [ t ] [ "<wm-root> handle-configure-request :: resize not requested"
- print flush ] } }
- cond
- 2drop ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces quotations arrays assocs sequences
- mortar slot-accessors x x.widgets.wm.menu x.widgets.wm.frame
- vars ;
-
-IN: x.widgets.wm.unmapped-frames-menu
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: <unmapped-frames-menu>
-
-<unmapped-frames-menu> <wm-menu> { } define-simple-class
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: unmapped-frames-menu
-
-: create-unmapped-frames-menu ( -- )
-<unmapped-frames-menu>
- new-empty
- <- keymenu-init
- 1 <-- set-border-width
->unmapped-frames-menu ;
-
-: unmapped-frames ( -- seq )
-dpy get $window-table values
-[ <wm-frame> is? ] filter [ <- mapped? not ] filter ;
-
-<unmapped-frames-menu> {
-
-"refresh" !( menu -- menu ) [
- unmapped-frames dup
- [ $child <- fetch-name ] map swap
- [ [ <- map ] curry ] map
- [ 2array ] 2map
- >>items
- dup <- calc-size <-- resize ]
-
-"popup" !( menu -- menu ) [ <- refresh <- wm-menu-popup ]
-
-} add-methods
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces namespaces.lib math sequences vars mortar
-accessors slot-accessors x ;
-
-IN: x.widgets.wm.workspace
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: workspace windows ;
-
-C: <workspace> workspace
-
-VAR: workspaces
-
-VAR: current-workspace
-
-: init-workspaces ( -- ) V{ } clone >workspaces ;
-
-: add-workspace ( -- ) { } clone <workspace> workspaces> push ;
-
-: mapped-windows ( -- seq )
-dpy get $default-root <- children [ <- mapped? ] filter ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: switch-to-workspace ( n -- )
-mapped-windows current-workspace> workspaces> nth (>>windows)
-mapped-windows [ <- unmap drop ] each
-dup workspaces> nth windows>> [ <- map drop ] each
-current-workspace set* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: next-workspace ( -- )
-current-workspace> 1+ dup workspaces> length <
-[ switch-to-workspace ] [ drop ] if ;
-
-: prev-workspace ( -- )
-current-workspace> 1- dup 0 >=
-[ switch-to-workspace ] [ drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: setup-workspaces ( n -- )
-workspaces>
- [ drop ]
- [ init-workspaces [ add-workspace ] times 0 >current-workspace ]
-if ;
\ No newline at end of file
+++ /dev/null
-
-USING: kernel io alien alien.c-types alien.strings namespaces threads
- arrays sequences assocs math vars combinators.lib
- x11.constants x11.events x11.xlib mortar slot-accessors geom.rect
- io.encodings.ascii ;
-
-IN: x
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: <display>
-
-SYMBOL: <window>
-
-! SYMBOL: dpy
-
-VAR: dpy
-
-<display>
- { "ptr"
- "name"
- "default-screen"
- "default-root"
- "default-gc"
- "black-pixel"
- "white-pixel"
- "colormap"
- "window-table" } accessors
-define-independent-class
-
-<display> "create" !( name <display> -- display ) [
- new-empty swap >>name
- dup $name dup [ ascii string>alien ] [ ] if XOpenDisplay
- dup [ >>ptr ] [ "XOpenDisplay error" throw ] if
- dup $ptr XDefaultScreen >>default-screen
- dup $ptr XDefaultRootWindow dupd <window> new >>default-root
- dup $ptr over $default-screen XDefaultGC >>default-gc
- dup $ptr over $default-screen XBlackPixel >>black-pixel
- dup $ptr over $default-screen XWhitePixel >>white-pixel
- dup $ptr over $default-screen XDefaultColormap >>colormap
- H{ } clone >>window-table
- [ <- start-event-loop ] in-thread
-] add-class-method
-
-{ "id" } accessors drop
-
-DEFER: check-window-table
-
-<display> {
-
-"add-to-window-table" !( display window -- )
- [ dup $id rot $window-table set-at ]
-
-"remove-from-window-table" !( display window -- )
- [ $id swap $window-table delete-at ]
-
-"next-event" !( display event -- display event )
- [ over $ptr over XNextEvent drop ]
-
-"events-queued" !( display mode -- n ) [ >r $ptr r> XEventsQueued ]
-
-"concurrent-next-event" !( display event -- display event )
- [ over QueuedAfterFlush <-- events-queued 0 >
- [ <-- next-event ] [ 100 sleep <-- concurrent-next-event ] if ]
-
-"event-loop" !( display event -- )
-[ <-- concurrent-next-event
- 2dup >r >r
- dup XAnyEvent-window rot $window-table at dup
- [ <- handle-event ] [ 2drop ] if
- r> r>
- <-- event-loop ]
-
-"start-event-loop" !( display -- ) [ "XEvent" <c-object> <-- event-loop ]
-
-"flush" !( display -- display ) [ dup $ptr XFlush drop ]
-
-"pointer-window" !( display -- window ) [
- dup $ptr
- over $default-root $id
- 0 <Window>
- 0 <Window> dup >r
- 0 <int>
- 0 <int>
- 0 <int>
- 0 <int>
- 0 <uint>
- XQueryPointer drop
- r> *Window <window> new
- check-window-table ]
-
-} add-methods
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<window> { "dpy" "id" } accessors define-independent-class
-
-: create-window ( -- window ) <window> new-empty <- init-window ;
-
-: create-window-from-id ( dpy id -- window ) <window> new ;
-
-: check-window-table ( window -- window )
- dup $id
- over $dpy $window-table
- at
- swap or ;
-
-<window> "init-window"
- !( window -- window )
- [ dpy get
- >>dpy
- dpy get $ptr
- dpy get $default-root $id
- 0 0 100 100 0
- dpy get $black-pixel
- dpy get $white-pixel
- XCreateSimpleWindow
- >>id ]
-add-method
-
-! <window> new-empty <- init
-
-<window> "raw"
- !( window -- dpy-ptr id )
- [ dup $dpy $ptr swap $id ]
-add-method
-
-<window> "move"
- !( window point -- window )
- [ >r dup <- raw r> first2 XMoveWindow drop ]
-add-method
-
-<window> "set-x" !( window x -- window ) [
- over <- y 2array <-- move
-] add-method
-
-<window> "set-y" !( window y -- window ) [
- over <- x swap 2array <-- move
-] add-method
-
-<window> "flush"
- !( window -- window )
- [ dup $dpy <- flush drop ]
-add-method
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 3 - Window Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! 3.3 - Creating Windows
-
-<window> "destroy" !( window -- window )
- [ dup <- raw XDestroyWindow drop ]
-add-method
-
-<window> "map"
- !( window -- window )
- [ dup <- raw XMapWindow drop ]
-add-method
-
-<window> "map-subwindows"
- !( window -- window )
- [ dup <- raw XMapSubwindows drop ]
-add-method
-
-<window> "unmap"
- !( window -- window )
- [ dup <- raw XUnmapWindow drop ]
-add-method
-
-<window> "unmap-subwindows"
- !( window -- window )
- [ dup <- raw XUnmapSubwindows drop ]
-add-method
-
-! 3.7 - Configuring Windows
-
-<window> "resize"
- !( window size -- window )
- [ >r dup <- raw r> first2 XResizeWindow drop ]
-add-method
-
-<window> "set-width"
- !( window width -- window )
- [ over <- height 2array <-- resize ]
-add-method
-
-<window> "set-height"
- !( window height -- window )
- [ over <- width swap 2array <-- resize ]
-add-method
-
-<window> "set-border-width"
- !( window n -- window )
- [ >r dup <- raw r> XSetWindowBorderWidth drop ]
-add-method
-
-! 3.8 Changing Window Stacking Order
-
-<window> "raise"
- !( window -- window )
- [ dup <- raw XRaiseWindow drop ]
-add-method
-
-<window> "lower"
- !( window -- window )
- [ dup <- raw XLowerWindow drop ]
-add-method
-
-! 3.9 - Changing Window Attributes
-
-! : change-window-attributes ( valuemask attr window -- )
-! -rot >r >r <- raw r> r> XChangeWindowAttributes drop ;
-
-<window> "change-attributes" !( window valuemask attr -- window ) [
->r >r dup <- raw r> r> XChangeWindowAttributes drop
-] add-method
-
-DEFER: lookup-color
-
-<window> "set-background"
- !( window color -- window )
- [ >r dup <- raw r> lookup-color XSetWindowBackground drop ]
-add-method
-
-<window> "set-gravity" !( window gravity -- window ) [
-CWWinGravity swap
-"XSetWindowAttributes" <c-object> tuck set-XSetWindowAttributes-win_gravity
-<--- change-attributes
-] add-method
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 4 - Window Information Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! 4.1 - Obtaining Window Information
-
-<window> {
-
-"children" !( window -- seq )
- [ <- raw 0 <uint> 0 <uint> f <void*> 0 <uint> 2dup >r >r XQueryTree drop
- r> r> swap *void* swap *uint c-uint-array>
- [ dpy get swap <window> new ] map ]
-
-"parent" !( window -- parent ) [
- dup $dpy >r
-
- dup $dpy $ptr
- swap $id
- 0 <Window>
- 0 <Window> dup >r
- f <void*>
- 0 <uint>
- XQueryTree drop
- r> *Window
- r> swap
- <window> new
- check-window-table ]
-
-"size" !( window -- size )
- [ <- raw 0 <Window> 0 <int> 0 <int>
- 0 <uint> 0 <uint> 2dup 2array >r
- 0 <uint> 0 <uint>
- XGetGeometry drop r> [ *uint ] map ]
-
-"width" !( window -- width ) [ <- size first ]
-
-"height" !( window -- height ) [ <- size second ]
-
-"position" !( window -- position )
- [ <- raw 0 <Window>
- 0 <uint> 0 <uint> 2dup 2array >r
- 0 <uint> 0 <uint> 0 <uint> 0 <uint>
- XGetGeometry drop r> [ *int ] map ]
-
-"x" !( window -- x ) [ <- position first ]
-
-"y" !( window -- y ) [ <- position second ]
-
-"as-rect" !( window -- rect ) [ dup <- position swap <- size <rect> new ]
-
-"attributes" !( window -- XWindowAttributes )
- [ <- raw "XWindowAttributes" <c-object> dup >r XGetWindowAttributes drop r> ]
-
-"map-state" !( window -- state ) [ <- attributes XWindowAttributes-map_state ]
-
-"mapped?" !( window -- ? ) [ <- map-state IsUnmapped = not ]
-
-} add-methods
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-atom-name ( atom -- name ) dpy get $ptr swap XGetAtomName ;
-
-: intern-atom ( atom-name only-if-exists? -- atom )
-dpy get $ptr -rot XInternAtom ;
-
-: lookup-color ( name -- pixel )
-dpy get $ptr dpy get $colormap rot
-"XColor" <c-object> dup >r "XColor" <c-object> XLookupColor drop
-dpy get $ptr dpy get $colormap r> dup >r XAllocColor drop r> XColor-pixel ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 8 - Graphics Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<window> "clear"
- !( window -- window )
- [ dup <- raw XClearWindow drop ]
-add-method
-
-<window> "draw-string"
- !( window gc pos string -- )
- [ >r >r >r <- raw r> $ptr r> [ >fixnum ] map first2 r> dup length
- XDrawString drop ]
-add-method
-
-! <window> "draw-string"
-! !( window gc pos string -- )
-! [ >r >r >r <- raw r> $ptr r> [ >fixnum ] map first2 r> dup length
-! XDrawString drop ]
-! add-method
-
-<window> "draw-line"
- !( window gc a b -- )
- [ >r >r >r <- raw r> $ptr r> first2 r> first2 XDrawLine drop ]
-add-method
-
-<window> "draw-rect"
- !( window gc rect -- )
- [ 3dup dup <- top-left swap <- top-right <---- draw-line
- 3dup dup <- top-right swap <- bottom-right <---- draw-line
- 3dup dup <- bottom-left swap <- bottom-right <---- draw-line
- dup <- top-left swap <- bottom-left <---- draw-line ]
-add-method
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 9 - Window and Session Manager Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<window> "reparent"
- !( window parent -- window )
- [ >r dup <- raw r> $id 0 0 XReparentWindow drop ]
-add-method
-
-<window> "add-to-save-set" !( window -- window ) [
- dup <- raw XAddToSaveSet drop
-] add-method
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 10 - Events
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: XButtonEvent-root-position ( event -- position )
-dup XButtonEvent-x_root swap XButtonEvent-y_root 2array ;
-
-: XMotionEvent-root-position ( event -- position )
-dup XMotionEvent-x_root swap XMotionEvent-y_root 2array ;
-
-! Utility words for XConfigureRequestEvent
-
-: XConfigureRequestEvent-position ( XConfigureRequestEvent -- position )
-dup XConfigureRequestEvent-x swap XConfigureRequestEvent-y 2array ;
-
-: XConfigureRequestEvent-size ( XConfigureRequestEvent -- size )
-dup XConfigureRequestEvent-width swap XConfigureRequestEvent-height 2array ;
-
-: bit-test ( a b -- t-or-f ) bitand 0 = not ;
-
-: CWX? ( XConfigureRequestEvent -- bool )
-XConfigureRequestEvent-value_mask CWX bit-test ;
-
-: CWY? ( XConfigureRequestEvent -- bool )
-XConfigureRequestEvent-value_mask CWY bit-test ;
-
-: CWWidth? ( XConfigureRequestEvent -- bool )
-XConfigureRequestEvent-value_mask CWWidth bit-test ;
-
-: CWHeight? ( XConfigureRequestEvent -- bool )
-XConfigureRequestEvent-value_mask CWHeight bit-test ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 11 - Event Handling Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<window> "select-input"
- !( window mask -- window )
- [ >r dup <- raw r> XSelectInput drop ]
-add-method
-
-! 11.8 - Handling Protocol Errors
-
-SYMBOL: error-handler-quot
-
-: error-handler-callback ( -- xt )
-"void" { "Display*" "XErrorEvent*" } "cdecl"
-[ error-handler-quot get call ] alien-callback ;
-
-: set-error-handler ( quot -- )
-error-handler-quot set error-handler-callback XSetErrorHandler drop ;
-
-: install-default-error-handler ( -- )
-[ "X11 : error-handler called" print flush ] set-error-handler ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 12 - Input Device Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! 12.2 - Keyboard Grabbing
-
-: grab-key
-( keycode modifiers grab-window owner-events pointer-mode keyboard-mode -- )
->r >r >r <- raw >r -rot r> r> r> r> XGrabKey drop ;
-
-! 12.5 - Controlling Input Focus
-
-<window> "set-input-focus" !( window revert-to time -- window )
- [ >r >r dup <- raw r> r> XSetInputFocus drop ]
-add-method
-
-: get-input-focus ( -- window )
- dpy> $ptr
- 0 <Window> dup >r
- 0 <int>
- XGetInputFocus drop
- r> *Window
- dpy> swap
- create-window-from-id
- check-window-table ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 14 - Inter-Client Communication Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-<window> "fetch-name" !( window -- name-or-f )
- [ <- raw f <void*> dup >r XFetchName drop r>
- dup *void* [ drop f ] [ *void* ascii alien>string ] if ]
-add-method
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! 16 - Application Utility Functions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! 16.1 - Using Keyboard Utility Functions
-
-! this should go in xlib.factor
-
-USING: alien.syntax ;
-
-FUNCTION: KeyCode XKeysymToKeycode ( Display* display, KeySym keysym ) ;
-
-FUNCTION: KeySym XKeycodeToKeysym ( Display* display,
- KeyCode keycode,
- int index ) ;
-
-FUNCTION: char* XKeysymToString ( KeySym keysym ) ;
-
-: keysym-to-keycode ( keysym -- keycode ) dpy get $ptr swap XKeysymToKeycode ;
-
-USE: strings
-
-: lookup-string* ( event -- keysym string )
-10 "char" <c-array> dup >r 10 0 <KeySym> dup >r f XLookupString
-r> *KeySym swap r> swap c-char-array> >string ;
-
-: lookup-string ( event -- string ) lookup-string* nip ;
-
-: lookup-keysym ( event -- keysym ) lookup-string* drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!7
-
-: event-to-keysym ( event index -- keysym )
->r dup XKeyEvent-display swap XKeyEvent-keycode r> XKeycodeToKeysym ;
-
-: keysym-to-string ( keysym -- string ) XKeysymToString ;
-
-: key-event-to-string ( event index -- str ) event-to-keysym keysym-to-string ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Misc
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: no-modifiers ( -- mask ) 0 ;
-
-: control-alt ( -- mask ) ControlMask Mod1Mask bitor ;
-
-: alt ( -- mask ) Mod1Mask ;
-
-: True 1 ;
-: False 0 ;
-
-<window> "send-client-message" !( window message-type data -- window ) [
-
-"XClientMessageEvent" <c-object>
-
-tuck set-XClientMessageEvent-data0
-tuck set-XClientMessageEvent-message_type
-over $id over set-XClientMessageEvent-window
-ClientMessage over set-XClientMessageEvent-type
-32 over set-XClientMessageEvent-format
-CurrentTime over set-XClientMessageEvent-data1
-
->r dup <- raw False NoEventMask r> XSendEvent drop
-
-] add-method
\ No newline at end of file
projects / factor.git / commitdiff