extra/arrays/shaped/shaped.factor

   1 ! Copyright (C) 2012 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators.short-circuit constructors
   4 fry grouping kernel math math.vectors sequences sequences.deep
   5 math.order parser assocs math.combinatorics ;
   6 IN: arrays.shaped
   7
   8 : flat? ( array -- ? ) [ sequence? ] any? not ; inline
   9
  10 GENERIC: array-replace ( object -- shape )
  11
  12 M: f array-replace ;
  13
  14 M: object array-replace drop f ;
  15
  16 M: sequence array-replace
  17     dup flat? [
  18         length
  19     ] [
  20         [ array-replace ] map
  21     ] if ;
  22
  23 TUPLE: uniform-shape shape ;
  24 C: <uniform-shape> uniform-shape
  25
  26 TUPLE: abnormal-shape shape ;
  27 C: <abnormal-shape> abnormal-shape
  28
  29 GENERIC: wrap-shape ( object -- shape )
  30
  31 M: integer wrap-shape
  32     1array <uniform-shape> ;
  33
  34 M: sequence wrap-shape
  35     dup all-equal? [
  36         [ length ] [ first ] bi 2array <uniform-shape>
  37     ] [
  38         <abnormal-shape>
  39     ] if ;
  40
  41 GENERIC: shape ( array -- shape )
  42
  43 M: sequence shape array-replace wrap-shape ;
  44
  45 : ndim ( array -- n ) shape length ;
  46
  47 ERROR: no-negative-shape-components shape ;
  48
  49 : check-shape-domain ( seq -- seq )
  50     dup [ 0 < ] any? [ no-negative-shape-components ] when ;
  51
  52 GENERIC: shape-capacity ( shape -- n )
  53
  54 M: sequence shape-capacity check-shape-domain product ;
  55
  56 M: uniform-shape shape-capacity
  57     shape>> product ;
  58
  59 M: abnormal-shape shape-capacity
  60     shape>> 0 swap [
  61         [ dup sequence? [ drop ] [ + ] if ] [ 1 + ] if*
  62     ] deep-each ;
  63
  64 ERROR: underlying-shape-mismatch underlying shape ;
  65
  66 ERROR: no-abnormally-shaped-arrays underlying shape ;
  67
  68 GENERIC: check-underlying-shape ( underlying shape -- underlying shape )
  69
  70 M: abnormal-shape check-underlying-shape
  71     no-abnormally-shaped-arrays ;
  72
  73 M: uniform-shape check-underlying-shape
  74     shape>> check-underlying-shape ;
  75
  76 M: sequence check-underlying-shape
  77     2dup [ length ] [ shape-capacity ] bi*
  78     = [ underlying-shape-mismatch ] unless ; inline
  79
  80 ERROR: shape-mismatch shaped0 shaped1 ;
  81
  82 : check-shape ( shaped-array shaped-array -- shaped-array shaped-array )
  83     2dup [ shape>> ] bi@
  84     sequence= [ shape-mismatch ] unless ;
  85
  86 TUPLE: shaped-array underlying shape ;
  87 TUPLE: row-array < shaped-array ;
  88 TUPLE: col-array < shaped-array ;
  89
  90 M: shaped-array length underlying>> length ; inline
  91
  92 M: shaped-array shape shape>> ;
  93
  94 : make-shaped-array ( underlying shape class -- shaped-array )
  95     [ check-underlying-shape ] dip new
  96         swap >>shape
  97         swap >>underlying ; inline
  98
  99 : <shaped-array> ( underlying shape -- shaped-array )
 100     shaped-array make-shaped-array ; inline
 101
 102 : <row-array> ( underlying shape -- shaped-array )
 103     row-array make-shaped-array ; inline
 104
 105 : <col-array> ( underlying shape -- shaped-array )
 106     col-array make-shaped-array ; inline
 107
 108 GENERIC: >shaped-array ( array -- shaped-array )
 109 GENERIC: >row-array ( array -- shaped-array )
 110 GENERIC: >col-array ( array -- shaped-array )
 111
 112 M: sequence >shaped-array
 113     [ { } flatten-as ] [ shape ] bi <shaped-array> ;
 114
 115 M: shaped-array >shaped-array ;
 116
 117 M: shaped-array >row-array
 118     [ underlying>> ] [ shape>> ] bi <row-array> ;
 119
 120 M: shaped-array >col-array
 121     [ underlying>> ] [ shape>> ] bi <col-array> ;
 122
 123 M: sequence >col-array
 124     [ flatten ] [ shape ] bi <col-array> ;
 125
 126 : shaped+ ( a b -- c )
 127     check-shape
 128     [ [ underlying>> ] bi@ v+ ]
 129     [ drop shape>> clone ] 2bi shaped-array boa ;
 130
 131 : shaped-array>array ( shaped-array -- array )
 132     [ underlying>> ] [ shape>> ] bi
 133     dup [ zero? ] any? [
 134         2drop { }
 135     ] [
 136         [ rest-slice reverse [ group ] each ] unless-empty
 137     ] if ;
 138
 139 : reshape ( shaped-array shape -- array )
 140     check-underlying-shape >>shape ;
 141
 142 : shaped-like ( shaped-array shape -- array )
 143     [ underlying>> clone ] dip <shaped-array> ;
 144
 145 : repeated-shaped ( shape element -- shaped-array )
 146     [ [ shape-capacity ] dip <array> ]
 147     [ drop 1 1 pad-head ] 2bi <shaped-array> ;
 148
 149 : zeros ( shape -- shaped-array ) 0 repeated-shaped ;
 150
 151 : ones ( shape -- shaped-array ) 1 repeated-shaped ;
 152
 153 : increasing ( shape -- shaped-array )
 154     [ shape-capacity <iota> >array ] [ ] bi <shaped-array> ;
 155
 156 : decreasing ( shape -- shaped-array )
 157     [ shape-capacity <iota> <reversed> >array ] [ ] bi <shaped-array> ;
 158
 159 : row-length ( shape -- n ) rest-slice product ; inline
 160
 161 : column-length ( shape -- n ) first ; inline
 162
 163 : each-row ( shaped-array quot -- )
 164     [ [ underlying>> ] [ shape>> row-length <groups> ] bi ] dip
 165     each ; inline
 166
 167 TUPLE: transposed shaped-array ;
 168
 169 : transposed-shape ( shaped-array -- shape )
 170     shape>> <reversed> ;
 171
 172 TUPLE: row-traverser shaped-array index ;
 173
 174 GENERIC: next-index ( object -- index )
 175
 176 SYNTAX: sa{ \ } [ >shaped-array ] parse-literal ;
 177
 178 USE: prettyprint.custom
 179 ! M: row-array pprint* shaped-array>array pprint* ;
 180 ! M: col-array pprint* shaped-array>array flip pprint* ;
 181 M: shaped-array pprint-delims drop \ sa{ \ } ;
 182 M: shaped-array >pprint-sequence shaped-array>array ;
 183 M: shaped-array pprint* pprint-object ;
 184 M: shaped-array pprint-narrow? drop f ;
 185
 186 ERROR: shaped-bounds-error seq shape ;
 187
 188 : shaped-bounds-check ( seq shaped -- seq shaped )
 189     2dup shape [ < ] 2all? [ shaped-bounds-error ] unless ;
 190
 191 ! Inefficient
 192 : calculate-row-major-index ( seq shape -- i )
 193     1 [ * ] accumulate nip reverse v* sum ;
 194
 195 : calculate-column-major-index ( seq shape -- i )
 196     1 [ * ] accumulate nip v* sum ;
 197
 198 : set-shaped-row-major ( obj seq shaped -- )
 199     shaped-bounds-check [ shape calculate-row-major-index ] [ underlying>> ] bi set-nth ;
 200
 201 : set-shaped-column-major ( obj seq shaped -- )
 202     shaped-bounds-check [ shape calculate-column-major-index ] [ underlying>> ] bi set-nth ;
 203
 204 ! Matrices
 205 : 2d? ( shape -- ? ) length 2 = ;
 206 ERROR: 2d-expected shaped ;
 207 : check-2d ( shaped -- shaped ) dup shape>> 2d? [ 2d-expected ] unless ;
 208
 209 : diagonal? ( coord -- ? ) { [ 2d? ] [ first2 = ] } 1&& ;
 210
 211 ! : definite? ( sa -- ? )
 212
 213 : shaped-each ( .. sa quot -- )
 214     [ underlying>> ] dip each ; inline
 215
 216 ! : set-shaped-where ( .. elt sa quot -- )
 217     ! [
 218         ! [ underlying>> [ length <iota> ] keep zip ]
 219         ! [ ] bi
 220     ! ] dip '[ _ [ _ set- ] @ ] assoc-each ; inline
 221
 222 : shaped-map! ( .. sa quot -- sa )
 223     '[ _ map ] change-underlying ; inline
 224
 225 : shaped-map ( .. sa quot -- sa' )
 226     [ [ underlying>> ] dip map ]
 227     [ drop shape>> ] 2bi <shaped-array> ; inline
 228
 229 : pad-shapes ( sa0 sa1 -- sa0' sa1' )
 230     2dup [ shape>> ] bi@
 231     2dup longer length '[ _ 1 pad-head ] bi@
 232     [ shaped-like ] bi-curry@ bi* ;
 233
 234 : output-shape ( sa0 sa1 -- shape )
 235     [ shape>> ] bi@
 236     [ 2dup [ zero? ] either? [ max ] [ 2drop 0 ] if ] 2map ;
 237
 238 : broadcast-shape-matches? ( sa broadcast-shape -- ? )
 239     [
 240         { [ drop 1 = ] [ = ] } 2||
 241     ] 2all? ;
 242
 243 : broadcastable? ( sa0 sa1 -- ? )
 244     pad-shapes
 245     [ [ shape>> ] bi@ ] [ output-shape ] 2bi
 246     '[ _ broadcast-shape-matches? ] both? ;
 247
 248 TUPLE: block-array shaped shape ;
 249
 250 : <block-array> ( underlying shape -- obj )
 251     block-array boa ;
 252
 253 : iteration-indices ( shaped -- seq )
 254     [ <iota> ] [
 255         cartesian-product concat
 256         [ dup first array? [ first2 suffix ] when ] map
 257     ] map-reduce ;
 258
 259 : map-shaped-index ( shaped quot -- shaped )
 260     over [
 261         [ [ underlying>> ] [ shape>> iteration-indices ] bi zip ] dip map
 262     ] dip swap >>underlying ; inline
 263
 264 : identity-matrix ( n -- shaped )
 265     dup 2array zeros [ second first2 = 1 0 ? ] map-shaped-index ;
 266
 267 : map-strict-lower ( shaped quot -- shaped )
 268     [ check-2d ] dip
 269     '[ first2 first2 > _ when ] map-shaped-index ; inline
 270
 271 : map-lower ( shaped quot -- shaped )
 272     [ check-2d ] dip
 273     '[ first2 first2 >= _ when ] map-shaped-index ; inline
 274
 275 : map-strict-upper ( shaped quot -- shaped )
 276     [ check-2d ] dip
 277     '[ first2 first2 < _ when ] map-shaped-index ; inline
 278
 279 : map-upper ( shaped quot -- shaped )
 280     [ check-2d ] dip
 281     '[ first2 first2 <= _ when ] map-shaped-index ; inline
 282
 283 : map-diagonal ( shaped quot -- shaped )
 284     [ check-2d ] dip
 285     '[ first2 first2 = _ when ] map-shaped-index ; inline
 286
 287 : upper ( shape obj -- shaped )
 288     [ zeros check-2d ] dip '[ drop _ ] map-upper ;
 289
 290 : strict-upper ( shape obj -- shaped )
 291     [ zeros check-2d ] dip '[ drop _ ] map-strict-upper ;
 292
 293 : lower ( shape obj -- shaped )
 294     [ zeros check-2d ] dip '[ drop _ ] map-lower ;
 295
 296 : strict-lower ( shape obj -- shaped )
 297     [ zeros check-2d ] dip '[ drop _ ] map-strict-lower ;