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 ( 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 ( seqs -- cross ) [ { { } } clone ] [ unclip swap n ] 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 [ 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 ; ! 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 ;