Paste: "the slow bit" of my program

USING: accessors assocs delegate fry kernel math math.parser math.ranges math.vectors namespaces prettyprint sequences ;

IN: rl.model

! --- DUNGEON ---

SYMBOL: 'dunj-size
SYMBOL: 'terrain
: init-dunj ( -- )  { 60 30 3 } 'dunj-size set  H{ } clone 'terrain set ;
: dunj-size ( -- xyz )  'dunj-size get ;
: within-map? ( pos -- ? )  dunj-size [ [0,b) member? ] 2all? ;
: +wall ( pos -- )  t swap 'terrain get set-at ;
: -wall ( pos -- )  'terrain get delete-at ;
: wall? ( pos -- ? )  'terrain get at ;

! ... parts omitted


USING: accessors arrays kernel math math.parser math.vectors random sequences strings unicode.case ;
USING: rl.model ;

IN: rl.utils

: dunj-width ( -- n )  dunj-size first ;
: dunj-height ( -- n )  dunj-size second ;
: dunj-depth ( -- n )  dunj-size third ;

: my-pos ( -- pos )  curr-actor pos>> ;
: curr-z ( -- z )  curr-actor pos>> third ;
: except-me ( ids -- ids )  curr-actor swap remove ;

: no-z ( xyz -- xy0 )  but-last 0 suffix ;
: dir-from ( dest src -- cmd )   v- [ sgn ] map ;

: rand-pos ( -- pos )  dunj-size [ random ] map ;
: rand-empty-tile ( -- pos )
    rand-pos dup can-enter? [ drop rand-empty-tile ] unless ;
: rand-delta ( -- delta )  { -1 0 1 } random ;

: sentence-case ( string -- string )  unclip 1string >upper prepend ;
: pos>string ( pos -- string )
  [ number>string ] map "," join "(" prepend ")" append ;

! --- SLICES ---

TUPLE: row y z ;
INSTANCE: row sequence  ! sequence of tiles
M: row length ( row -- ncols )  drop dunj-width ;
: >row< ( row -- y z )  dup y>> swap z>> ;
M: row nth ( n row -- tile )  >row< 3array ;

TUPLE: layer z ;
INSTANCE: layer sequence  ! sequence of layers
M: layer length ( layer -- nrows )  drop dunj-height ;
M: layer nth ( z layer -- row )  z>> row boa ;

: dunj-layer ( num -- layer ) layer boa ;

! --- CROSS PRODUCTS ---

TUPLE: cross first rest ;
C: <cross> cross ( seq cross -- cross )
: >cross< ( cross -- first rest )  dup first>> swap rest>> ;
INSTANCE: cross sequence
: indexes ( n cross -- first-n rest-n )  rest>> length /mod ;
: 2nth ( n1 n2 seq1 seq2 -- elt1 elt2 )  swapd [ nth ] 2bi@ ;
M: cross nth  [ indexes ] keep >cross< 2nth swap prefix ;
M: cross length  dup first>> length swap rest>> length * ;
: n<cross> ( seqs -- 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 -- range )
    interval>points [ first2 ] bi@ swapd
    [ [ r:[a,b] ] [ r:(a,b] ] if ]
    [ [ r:[a,b) ] [ r:(a,b) ] if ] if ;

: diag-matrix ( vec -- vecs )
    dup length 0 <array> [ clone [ set-nth ] keep ] curry map-index ;

! a rectangle (or cuboid) is a sequence of math.intervals
: within-rect? ( p rect -- ? )  [ interval-contains? ] 2all? ;
: interval-overlap? ( int1 int2 -- ? )
    interval-intersect empty-interval = not ;
: overlap? ( rect rect -- ? )  [ interval-overlap? ] 2all? ;
: r-center ( rect -- vec )  [ interval>points [ first ] bi@ + 2/ ] map ;
: shift ( rect vec -- vec )  [ [a,a] interval+ ] 2map ;
: components ( vec -- vecs )  diag-matrix [ [ zero? ] all? not ] filter ;
: approaches ( dest rect -- vecs )  r-center dir-from components ;
: steps ( vecs rect -- rects )  [ swap shift ] curry map ;
: nexts ( dest rect -- rects )  [ approaches ] keep steps ;

! we can start 1 dungeon-size diagonally beyond a dungeon corner
: beyonds ( dimension -- extremes )
    [ drop -1 >integer ] [ 1+ >integer ] bi 2array ;
: [0,a) ( x -- int )  0 swap [a,b) ;
: [-a,0) ( x -- int )  neg 0 [a,b) ;
: extend-away ( dim -- intervals )  dup [-a,0) swap [0,a) 2array ;
: start-components ( rect-dim dunj-dim -- ranges )
    [ extend-away ] [ beyonds ] bi*  [ [a,a] interval+ ] 2map ;
: starts ( r-size d-size -- rects )  [ start-components ] 2map n<cross> ;

! rectangular particle aggregation
SYMBOL: rooms  ! list of rects
: collides? ( rect -- ? )  [ overlap? ] curry  rooms get  swap any? ;
: non-colliding ( rects -- rects )  [ collides? not ] filter ;
: wander1 ( dest rect -- rect/f )  nexts non-colliding random ;
: wander ( dest rect -- rect )  2dup wander1 [ nip wander ] [ nip ] if* ;
DEFER: rand-size ( -- r-size )
: rand-start ( r-size d-size -- rect/f )  starts non-colliding random ;
: d-center ( size -- size )  [ 2/ ] map ;
: aggregate1 ( d-size -- rect/f )
    [ d-center rand-size ] keep rand-start [ wander ] [ drop f ] if* ;
: +room ( rect -- )  rooms [ swap suffix ] change ;
: (aggregate) ( d-size -- )
    dup aggregate1 [ +room yield (aggregate) ] [ drop ] if* ;
: aggregate ( d-size -- rects )
    { } rooms [ (aggregate) rooms get ] with-variable ;
Author:	Simon Richard Clarkstone
Mode:	factor
Date:	Sun, 15 Mar 2009 22:44:14