\* Nibble compiler for step-lists *\ \* Given pointers to 4 nibbles that one desires to assemble from various subcells, "assemble-nibbles" produces code that brings these nibbles together into one subcell. Each "assemble-nibbles" begins by calling "restore-nibbles" to restore the (updated) nibble values to where they came from before the previous "assemble-nibbles". A final "restore-nibbles" and "0 goto-subcell" at the end of the step will leave everything where it started. *\ load /cam8/working/step/step-perm-nibl.fth \ definitions for permuting tables \* Whenever we do an "assemble-cell", we remember which nibbles we assembled by modifying the subcell numbers associated with "old-nib0", etc. Each new subcell assembly then starts by removing the old nibbles, then assembling new nibbles, and remembering those. If we performed a permutation after the assembly, we must thus remember to undo the permutation before we undo the assembly. *\ 0 3 == old-nib0 4 7 == old-nib1 8 11 == old-nib2 12 15 == old-nib3 : old-nib-n {{ old-nib0 old-nib1 old-nib2 old-nib3 }} ; : >subcell (s cfa.== -- ) >body 2 la+ ; \ addr. of subcell : >old-sub0 (s subcell# -- ) ['] old-nib0 >subcell ! ; : >old-sub1 (s subcell# -- ) ['] old-nib1 >subcell ! ; : >old-sub2 (s subcell# -- ) ['] old-nib2 >subcell ! ; : >old-sub3 (s subcell# -- ) ['] old-nib3 >subcell ! ; : >old-sub-n {{ >old-sub0 >old-sub1 >old-sub2 >old-sub3 }} ; \* We may need to modify or interrogate the subcell number or layer-mask determined by the current "field". Since we're dealing with nibbles, we will typically only care about which nibble is singled out, rather than the raw bits of the layer mask. *\ : nib# (s -- nib# ) 0 4 0 do layer-mask @ i 4* >> f and 0<> if drop i then loop ; : sub# (s -- sub# ) assemble-subcell# @ ; : >nib# (s nib# -- ) 4 * h# f swap << layer-mask ! ; : >sub# (s sub# -- ) assemble-subcell# ! ; \* To assemble all of the bits of a given subcell, we must remove whatever nibbles are currently present, bring in the nibbles of the indicated subcell, and then remember that all four nibbles currently come from this subcell. *\ : goto-subcell (s n -- ) assemble-cell 4 0 do i old-nib-n field remove loop cell field dup >sub# add dup >old-sub0 dup >old-sub1 dup >old-sub2 >old-sub3 ; \* To permute the bits in a given subcell, we first check that the indicated permutation is not the identity perm (if it is we do nothing). We then goto the indicated subcell, and do the permutation. *\ : ?do-subcell-perm (s perm.double subcell# -- ) -rot 2dup identity-perm d= if 3drop exit else rot then goto-subcell ?do-perm ; \* We keep a list of permuations for each subcell, in case we want to be able to undo permutations on subcells. *\ max#subcells 2array perm-list : init-perm-list max#subcells 0 ?do identity-perm i perm-list 2! loop ; \* "restore-nibbles" undoes any "post-perm" permutation and undoes any separate subcell permutations that "assemble-nibbles" may have done. It then re-initializes the variables that save the information about what permutations have been done. *\ 2variable post-perm : restore-nibbles post-perm 2@ inverse-perm ?do-perm max#subcells 0 ?do i perm-list 2@ inverse-perm i ?do-subcell-perm loop init-perm-list identity-perm post-perm 2! ; \* "add-nibbles-to-perm" is a specialization of "add-to-perm". It incrementally generates a permutation code that embodies all of the nibble permutations that have been indicated, if this is possible. "nib-perm@" and "nib-perm!" directly modify the indicated perm code, and don't gaurantee that it will remain a permutation. They are included here for debugging convenience. *\ : nib-perm@ (s dest-nib addr.perm -- source-nib ) swap 4* swap nib2@ 4 / ; : nib-perm! (s source-nib dest-nib addr.perm -- ) 4 0 do 3dup drop 4* i + swap 4* i + swap 2over nip nib2! loop 3drop ; : add-nibble-to-perm (s source.nib# dest.nib# addr.perm -- ) 4 0 do 3dup drop 4* i + swap 4* i + swap 2over nip add-to-perm loop 3drop ; \* "assemble-nibbles" is the main routine. It performs only one optimization, in addition to the one performed by the routines that actually do the permutations (they do nothing if the perm is the identity). The "assemble-nibbles" optimization is that it checks if the positions of the four specified nibbles overlap. If they do, we first permute the subcells containing these nibbles to put them in the positions where they will be needed. If they don't overlap, we can save time by assembling the nibbles first, and then permuting them all at once. *\ defer nib0 defer nib1 defer nib2 defer nib3 : nib-n {{ nib0 nib1 nib2 nib3 }} ; : .nibbles (s cfa0 cfa1 cfa2 cfa3 -- ) perm-verbose @ not if 2drop 2drop exit then 4 reverse 4 0 do .name loop cr ; : assemble-nibbles (s cfa0 cfa1 cfa2 cfa3 -- ) 2over 2over .nibbles is nib3 is nib2 is nib1 is nib0 restore-nibbles 0 4 1 do i nib-n field nib# nib0 field nib# = or loop 4 2 do i nib-n field nib# nib1 field nib# = or loop 4 3 do i nib-n field nib# nib2 field nib# = or loop \* If some nibbles are in the same position, we'll permute and then assemble. *\ if 4 0 do i nib-n field nib# i sub# perm-list add-nibble-to-perm loop max#subcells 0 ?do i perm-list 2@ i ?do-subcell-perm loop assemble-cell 4 0 do i old-nib-n field remove loop 4 0 do i nib-n field i >nib# add loop \ remember which subcell each nibble came from 4 0 do i nib-n field sub# i >old-sub-n loop \* Otherwise, we assemble first, and then permute. *\ else assemble-cell 4 0 do i old-nib-n field remove loop 4 0 do i nib-n field add loop \ remember which subcell and position each nibble came from 4 0 do i nib-n field sub# nib# >old-sub-n loop 4 0 do i nib-n field nib# i post-perm add-nibble-to-perm loop post-perm 2@ ?do-perm then ; : restore-subcell (s n -- ) restore-nibbles goto-subcell ; \* If this code were added to the system, the initialization need when you start a new experiment would consist of: setting all pointers to which subcell nibbles are in use to point to subcell 0, and initializing the permutations restored bye "restore-nibbles" to all be the identity permutation. *\ : init-nibble-compiler 4 0 do 0 i >old-sub-n loop identity-perm post-perm 2! init-perm-list ; init-nibble-compiler