Initial data commit

Task/Multi-dimensional-array/Forth/multi-dimensional-array-2.fth

@@ -0,0 +1,74 @@
+\ Values used to avoid locals or some confusing stack juggling.
+\ They could be replaced by locals if preferred.
+0 VALUE addr
+0 VALUE ndims
+: darray    \ Create: d(n-1) .. d0 size n "<name-of-array>" --  ;
+            \ Does:  ix[n-1] .. ix0 -- addr
+            \ Creates an n dimensional array with axes dn-1 .. d0
+
+  \ d(n-i)  .. d0 - the length of the n dimensions.
+  \ size          - The size in bytes of the basic elenment in the array.
+  \               - e.g 1 for chars, 2 for 16 bit etc..
+  \ n - The number of dimensions
+
+  \ Term stride is taken from numpy.  It's the gap between consqutive indices
+  \ in a given dimension.  ix * stride gives an offset from a base address.
+
+  \ CELLS           0               1         2    ...     n+1   n+2 ->
+  \    Stride[0] addr  Stride[n] addr  stride[0]    stride[n-1]  data ->
+  \           CELL[2]       CELL[n+2]       size
+  \ Storing the stride addresses at CELLS 0 and 1 gives fast access for
+  \ the do loop in the DOES> section to loop through the strides.
+
+  CREATE
+    IS ndims   HERE IS addr        \ n to ndims, HERE to addr
+    0 , 0 ,                        \ Placeholders for loop-bounds
+    DUP ,                          \ size stored at CELL[2]
+    ndims 1- 0 ?DO   * DUP , LOOP  \ Calculate and store strides 1 to n-1.
+    HERE addr CELL + !             \ Store high address for strides
+    * ALLOT                        \ Calculate and allocate the space
+    addr 2 CELLS + addr !          \ Calculate & store low addr for strides
+
+  DOES>     \ ix[n-1] .. ix[0] -- addr ;
+    2@ OVER SWAP   ( data-addr stride-addr[n] stride-addr[0] )
+    ?DO
+      SWAP i @ * +    \ multiply strides by indices and add to base address
+    CELL +LOOP ;
+
+  2 3 4 5 CELL 4 darray test4d \ 4d array of integers
+\ 2 3 4 5   20 4 darray 20byte-records-4D
+
+\ Word to fill the array
+: test4d-fill
+  2 0 DO i
+    3 0 DO i
+      4 0 DO
+        5 0 DO
+          2DUP 100 * SWAP 1000 * +
+          j 10 * + i +
+          2 PICK 2 PICK j i test4d !
+        LOOP
+      LOOP
+    DROP LOOP
+  DROP LOOP ;
+
+: [.  ." [ " ;
+: ].  ." ] " ;
+
+defer p-array
+: print-4d    \ <array-name> -- ; Prints 4d array
+  ' IS p-array
+  2 0 DO i CR [.
+    3 0 DO i CR 2 SPACES [.
+      4 0 DO
+        CR 4 SPACES [.
+        5 0 DO
+          2DUP j i p-array @ 8 .r
+        LOOP ].
+      LOOP ].
+    DROP LOOP ].
+  DROP LOOP ;
+
+test4d-fill
+
+print-4d test4d