Remove some stuff from unmaintained, and put some extra stuff there
Slava Pestov
parent
375c5e69b5
commit
c1792d169e
|
|
@ -1 +0,0 @@
|
||||||
Eduardo Cavazos
|
|
||||||
|
|
@ -1,17 +0,0 @@
|
||||||
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
|
|
||||||
|
|
||||||
|
|
@ -1,49 +0,0 @@
|
||||||
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
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Non-core assoc words
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
collections
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Eduardo Cavazos
|
|
||||||
|
|
@ -1,28 +0,0 @@
|
||||||
|
|
||||||
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*
|
|
||||||
|
|
||||||
|
|
@ -1,97 +0,0 @@
|
||||||
|
|
||||||
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
|
|
||||||
|
|
@ -1,89 +0,0 @@
|
||||||
|
|
||||||
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*
|
|
||||||
|
|
||||||
|
|
@ -1,80 +0,0 @@
|
||||||
|
|
||||||
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
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Bake is similar to make but with additional features
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Daniel Ehrenberg
|
|
||||||
|
|
@ -1,17 +0,0 @@
|
||||||
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." } ;
|
|
||||||
|
|
@ -1,22 +0,0 @@
|
||||||
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
|
|
||||||
|
|
@ -1,111 +0,0 @@
|
||||||
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
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Simple system for specifying packed bitfields
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
extensions
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Adam Wendt
|
|
||||||
|
|
@ -1,16 +0,0 @@
|
||||||
|
|
||||||
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 ;
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Eduardo Cavazos
|
|
||||||
|
|
@ -1,22 +0,0 @@
|
||||||
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"
|
|
||||||
""
|
|
||||||
} ;
|
|
||||||
|
|
@ -1,24 +0,0 @@
|
||||||
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
|
|
||||||
|
|
@ -1,138 +0,0 @@
|
||||||
! 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
|
|
||||||
|
|
@ -1,108 +0,0 @@
|
||||||
! 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 ;
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Eduardo Cavazos
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Eduardo Cavazos
|
|
||||||
|
|
@ -1,73 +0,0 @@
|
||||||
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* ] }
|
|
||||||
|
|
@ -1,122 +0,0 @@
|
||||||
! -*-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
|
|
||||||
|
|
||||||
|
|
@ -1,26 +0,0 @@
|
||||||
! -*-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
|
|
||||||
|
|
@ -1,37 +0,0 @@
|
||||||
|
|
||||||
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
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Eduardo Cavazos
|
|
||||||
|
|
@ -1,32 +0,0 @@
|
||||||
|
|
||||||
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 ;
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Window manager for the X Window System
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
applications
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Eduardo Cavazos
|
|
||||||
|
|
@ -1,23 +0,0 @@
|
||||||
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 ) ;
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Alex Chapman
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Alex Chapman
|
|
||||||
|
|
@ -1,17 +0,0 @@
|
||||||
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
|
|
||||||
|
|
@ -1,94 +0,0 @@
|
||||||
! 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* ;
|
|
||||||
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Collection of 'cursors' representing locations in a gap buffer
|
|
||||||
|
|
@ -1,40 +0,0 @@
|
||||||
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
|
|
||||||
|
|
||||||
|
|
@ -1,294 +0,0 @@
|
||||||
! 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 ;
|
|
||||||
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Gap buffer data structure
|
|
||||||
|
|
@ -1,2 +0,0 @@
|
||||||
collections
|
|
||||||
sequences
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Eduardo Cavazos
|
|
||||||
|
|
@ -1,16 +0,0 @@
|
||||||
|
|
||||||
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
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Eduardo Cavazos
|
|
||||||
|
|
@ -1,28 +0,0 @@
|
||||||
|
|
||||||
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
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Eduardo Cavazos
|
|
||||||
|
|
@ -1,41 +0,0 @@
|
||||||
|
|
||||||
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
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Adam Wendt
|
|
||||||
|
|
@ -1,29 +0,0 @@
|
||||||
! 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." } ;
|
|
||||||
|
|
@ -1,142 +0,0 @@
|
||||||
! 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 ;
|
|
||||||
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
ID3 music file tag parser
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Eduardo Cavazos
|
|
||||||
|
|
@ -1,98 +0,0 @@
|
||||||
|
|
||||||
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 ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Eduardo Cavazos
|
|
||||||
|
|
@ -1,60 +0,0 @@
|
||||||
|
|
||||||
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 ;
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
unportable
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Alex Chapman
|
|
||||||
|
|
@ -1,12 +0,0 @@
|
||||||
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" }
|
|
||||||
}
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Alex Chapman
|
|
||||||
|
|
@ -1,40 +0,0 @@
|
||||||
! 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 ;
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Alex Chapman
|
|
||||||
|
|
@ -1,99 +0,0 @@
|
||||||
! 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 ;
|
|
||||||
|
|
||||||
|
|
@ -1,94 +0,0 @@
|
||||||
! 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
|
|
||||||
|
|
@ -1,10 +0,0 @@
|
||||||
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...
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Alex Chapman
|
|
||||||
|
|
@ -1,8 +0,0 @@
|
||||||
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
|
|
||||||
|
|
@ -1,73 +0,0 @@
|
||||||
! 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 ;
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Alex Chapman
|
|
||||||
|
|
@ -1,137 +0,0 @@
|
||||||
! 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 ;
|
|
||||||
Binary file not shown.
|
|
@ -1,15 +0,0 @@
|
||||||
! 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 ;
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
A simple 3d tunnel racing game
|
|
||||||
|
|
@ -1,2 +0,0 @@
|
||||||
applications
|
|
||||||
games
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Alex Chapman
|
|
||||||
|
|
@ -1,45 +0,0 @@
|
||||||
! 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
|
|
||||||
|
|
@ -1,167 +0,0 @@
|
||||||
! 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 ;
|
|
||||||
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
James Cash
|
|
||||||
|
|
@ -1,22 +0,0 @@
|
||||||
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"
|
|
||||||
|
|
@ -1,94 +0,0 @@
|
||||||
! 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
|
|
||||||
|
|
@ -1,178 +0,0 @@
|
||||||
! 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
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
James Cash
|
|
||||||
|
|
@ -1,6 +0,0 @@
|
||||||
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." ;
|
|
||||||
|
|
@ -1,80 +0,0 @@
|
||||||
! 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
|
|
||||||
|
|
@ -1,41 +0,0 @@
|
||||||
! 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
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
EBNF grammar for parsing Lisp
|
|
||||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue