Paste: "the slow bit" of my program
Author: | Simon Richard Clarkstone |
Mode: | factor |
Date: | Sun, 15 Mar 2009 22:44:14 |
Plain Text |
USING: accessors assocs delegate fry kernel math math.parser math.ranges math.vectors namespaces prettyprint sequences ;
IN: rl.model
SYMBOL: 'dunj-size
SYMBOL: 'terrain
: init-dunj { 60 30 3 } 'dunj-size set H{ } clone 'terrain set ;
: dunj-size 'dunj-size get ;
: within-map? dunj-size [ [0,b) member? ] 2all? ;
: +wall t swap 'terrain get set-at ;
: -wall 'terrain get delete-at ;
: wall? 'terrain get at ;
USING: accessors arrays kernel math math.parser math.vectors random sequences strings unicode.case ;
USING: rl.model ;
IN: rl.utils
: dunj-width dunj-size first ;
: dunj-height dunj-size second ;
: dunj-depth dunj-size third ;
: my-pos curr-actor pos>> ;
: curr-z curr-actor pos>> third ;
: except-me curr-actor swap remove ;
: no-z but-last 0 suffix ;
: dir-from v- [ sgn ] map ;
: rand-pos dunj-size [ random ] map ;
: rand-empty-tile
rand-pos dup can-enter? [ drop rand-empty-tile ] unless ;
: rand-delta { -1 0 1 } random ;
: sentence-case unclip 1string >upper prepend ;
: pos>string
[ number>string ] map "," join "(" prepend ")" append ;
TUPLE: row y z ;
INSTANCE: row sequence
M: row length drop dunj-width ;
: >row< dup y>> swap z>> ;
M: row nth >row< 3array ;
TUPLE: layer z ;
INSTANCE: layer sequence
M: layer length drop dunj-height ;
M: layer nth z>> row boa ;
: dunj-layer layer boa ;
TUPLE: cross first rest ;
C: <cross> cross
: >cross< dup first>> swap rest>> ;
INSTANCE: cross sequence
: indexes rest>> length /mod ;
: 2nth swapd [ nth ] 2bi@ ;
M: cross nth [ indexes ] keep >cross< 2nth swap prefix ;
M: cross length dup first>> length swap rest>> length * ;
: n<cross>
[ { { } } clone ] [ unclip swap n<cross> <cross> ] if-empty ;
USING: accessors arrays combinators kernel math math.intervals math.vectors namespaces random threads sequences ;
QUALIFIED-WITH: math.ranges r
USING: rl.model rl.utils ;
IN: rl.new.rooms
: interval>range
interval>points [ first2 ] bi@ swapd
[ [ r:[a,b] ] [ r:(a,b] ] if ]
[ [ r:[a,b) ] [ r:(a,b) ] if ] if ;
: diag-matrix
dup length 0 <array> [ clone [ set-nth ] keep ] curry map-index ;
: within-rect? [ interval-contains? ] 2all? ;
: interval-overlap?
interval-intersect empty-interval = not ;
: overlap? [ interval-overlap? ] 2all? ;
: r-center [ interval>points [ first ] bi@ + 2/ ] map ;
: shift [ [a,a] interval+ ] 2map ;
: components diag-matrix [ [ zero? ] all? not ] filter ;
: approaches r-center dir-from components ;
: steps [ swap shift ] curry map ;
: nexts [ approaches ] keep steps ;
: beyonds
[ drop -1 >integer ] [ 1+ >integer ] bi 2array ;
: [0,a) 0 swap [a,b) ;
: [-a,0) neg 0 [a,b) ;
: extend-away dup [-a,0) swap [0,a) 2array ;
: start-components
[ extend-away ] [ beyonds ] bi* [ [a,a] interval+ ] 2map ;
: starts [ start-components ] 2map n<cross> ;
SYMBOL: rooms
: collides? [ overlap? ] curry rooms get swap any? ;
: non-colliding [ collides? not ] filter ;
: wander1 nexts non-colliding random ;
: wander 2dup wander1 [ nip wander ] [ nip ] if* ;
DEFER: rand-size
: rand-start starts non-colliding random ;
: d-center [ 2/ ] map ;
: aggregate1
[ d-center rand-size ] keep rand-start [ wander ] [ drop f ] if* ;
: +room rooms [ swap suffix ] change ;
: (aggregate)
dup aggregate1 [ +room yield (aggregate) ] [ drop ] if* ;
: aggregate
{ } rooms [ (aggregate) rooms get ] with-variable ;
New Annotation