perl and forth

if you're look at the faq for blogging - i think it says somewhere no confessions.

certainly my confessions would be ( how easy is it to connect to a perl service ).

O I am sure that perl and forth are different --- yet I am a bit confused exactly

about how --- and can you break that thin gray line?

In fact is there a thin grey line?

I just think that if there is a thin grey line it something like ---

///   how is some old fashion notion --- a new fashion notion ///

like a cycling --- tensor - ( rotation ) ..

a link somewhere .

I have a lots to confess - so I won't.

Note: this somewhat anticpates itsy - vs parrot forth sometime in the future of this draft
which makes it almost daft.....

Forth on the Fifth

I was shooting for a forth on the fourth --- but, no way.  I guess I might have to wait
for another " Fourth/fourth "  ??????

Anyway, futzing quite along, I create this new object - which I need to futz with yet more
but just so I'm close to the fourth --- this is it:

\ sq-obj
object class pre-sq
   method set-sq
   method print-sq
   method load-sq
class;

pre-sq class sq-obj
     cell var offset
     cell var index1-1
     cell var index1-2
     cell var index2-1
     cell var index2-2
     cell var square-no
how:
: set-sq ( n -- )
     dup square-no ! 1 = if 0 offset ! 3 index1-1 ! 0 index1-2 ! 3 index2-1 ! 0 index2-2 ! else
         square-no @   2  = if 3 offset ! 3 index1-1 ! 0 index1-2 ! 3 index2-1 ! 0 index2-2 ! else
          square-no @  3 = if 6 offset ! 3 index1-1 ! 0 index1-2 ! 3 index2-1 ! 0 index2-2 ! else
         square-no @ 4  = if 0 offset ! 6 index1-1 ! 3 index1-2 ! 3 index2-1 ! 0 index2-2 ! else
          square-no @  5 = if 3 offset ! 3 index1-1 ! 0 index1-2 ! 3 index2-1 ! 0 index2-2 ! else
\  bologna, ketchup, and lettuce
           square-no @ 6  if 6 offset ! 3 index1-1 ! 0 index1-2 ! 3 index2-1 ! 0 index2-2 ! else
           square-no @ 7 = if 0 offset ! 9 index1-1 ! 6 index1-2 ! 3 index2-1 ! 0 index2-2 ! else
          square-no @  8  = if 3 offset ! 9 index1-1 ! 6 index1-2 ! 3 index2-1 ! 0 index2-2 ! else
          square-no @ 9 = if 6 offset ! 9 index1-1 ! 6 index1-2 ! 3 index2-1 ! 0 index2-2 ! then
                      then then then then then then then ;

: print-sq ( n -- ) set-sq
       index1-1 @ index1-2 @  ?do i line-no-here !
       index1-1 @ index1-2 @ ?do i column-calc2 + offset-here @ + c@ emit
       loop loop ;

class;
\  end class

And it's also interesting to note that index2-1 is alway 3 and index2-2 is always 0 ???

Pattern Matching

I am not sure what I'm looking at -------

Now back to my collector obsessions ---

Here it is modified to use the oof - array and that does somewhat reduce the size and complexity ---

Now the following will demonstrate an interesting point ---- the process of removing errors - when I change course in what I'm doing --- In this case I had the clever idea about changing state because I was eliminating some other code ( specifically - nzp@ )

Anyone, one more pattern to match:

\-- find not contained in one array and put it into a second array

\-- for sudoku solver

\-- arraycollector.fs

include oofarray.fs

create vbp_ 9 cells allot

create vbpx_ 9 cells allot

42 42 42 42 42 42 42 42 42 9 int new[] 9 array : vbp

42 42 42 42 42 42 42 42 42 9 int new[] 9 array : vbpx

obj class precollector

        method nextval@ 

   method nextval!

   method sv-next@

   method sv-next!

   method nv@

   method nv!

   method dump-collection

   method nextval-prt

   method reset-all

   method sv-nextval

   method reset-nextval

   method check-unique

   method store-input

   method backup-current-vpb

   method restore-current-vpb

   method backup-current-vpbx

   method restore-current-vpbx

   method backup-current

   method restore-current

   method nextvalinc

   method mode-set-1

   method mode-init

   method mode-get

   method mode-get-prt 

   method mode-swt

   method check-possible 

   method store-possible-lcl 

   method find-possible-lcl

   method get-first

   method set-this-collection-max

   method get-this-collection-max

   method process-empty-space

class;

precollector class arraycollector

     cell var nextval

     cell var sv-next

     cell var inpv

     cell var dupr 

     cell var lclvbp

     cell var lclvbpx

     cell var mode

     cell var fnd

     cell var collection-max

how:

: store-cell board line-no + col-no 9 * + nvp@ ! ;

: nextval@ nextval @ ;

: nextval! nextval ! ;

: nextvalinc nextval@ 1 + nextval! ;

: sv-next@ sv-next @ ;

: sv-next! sv-next ! ;

: nv!  nextval@ 1 - vbp ! ; 

: nv@  nextval@ 1 - vbp @ ;

: nvp!  nextval@ 1 - vpbx ! ; 

: nvp@  nextval@ 1 - vpbx @ ;

: reset-nextval sv-next@ nextval! ;

: sv-nextval nextval@ sv-next! ;

: nextval-prt cr s" nextval = " type nextval@ . ;

: reset-all 10 1 ?do i nextval! 42 nv! loop 1 nextval ! ;

: dump-collection sv-nextval 10 1 ?do i nextval! nv@ dup 10 < if . else emit then s" - " type loop reset-nextval ;

: check-unique inpv !  0 dupr ! sv-nextval

                     10 1 ?do i nextval! nv@ inpv @ = if 1 dupr ! leave then loop 

                        reset-nextval dupr @ ;

: get-first sv-nextval 1 nextval ! nv@ reset-nextval ;

: store-input check-unique 0 = if inpv @ nv! nextval@ 1 + nextval! then ;

: check-possible nextpval @ 1 - ;

: store-possible nvp! nextpval @ 1 + nextpval ! ;

: find-possible 0 fnd ! 10 1 ?do i dup check-val ! nextval! nv@ check-val @ = if 1 fnd ! then loop fnd @ 0 = if store-possible then ;

class;

Dipsy Doodle

This is actually about array using oof ---

or maybe oof arrays --- technically I'm not sure ---

for historical reference, this could be helpful -----

Covering Tommy Dorsey's 1937 hit, Larry Clinton & His Orchestra perform the titular big-band classic in the soundie Dipsy Doodle (1943). This number was often covered, notably by Ella Fitzgerald with Chick Webb's orchestra, & even by Bill Haley & the Comets, besides being goofed up by Homer & Jethro.
from : http://www.weirdwildrealm.com/f-larry-clinton.html



From some where - or maybe here - I acquired on oof array --- what I'm talking about :

https://github.com/BlastarIndia/Blastarix/blob/master/gforth-0.7.2/oofsampl.fs

and I created this " beasty " :

/ oofarray.fs
include oof.fs
: i! postpone ! ; immediate
: i@ postpone @ ; immediate
object class data \ abstract data class
        cell var ref \ reference counter
        method ! method @ method .
        method null method atom? method #
how: : atom? ( -- flag ) true ;
        : # ( -- n ) 0 ;
        : null ( -- addr ) new ;
class;
\ Data structures: int 30apr93py

data class int
        cell var value
how: : ! value i! ;
        : @ value i@ ;
        : . @ 0 .r ;
        : init ( data -- ) ! ;
        : dispose -1 ref +!
          ref i@ 0> 0= IF super dispose THEN ;
        : null 0 new ;
class;

\ Data sturctures: array 30apr93py

data class array
        data [] container
        cell var range
how: : ! container ! ;
        : @ container @ ;
        : . [char] [
                # 0 ?DO emit I container . [char] , LOOP drop ." ]" ;
        : init ( data n -- ) range i! bind container ;
        : dispose -1 ref +! ref i@ 0> 0=
          IF # 0 ?DO I container dispose LOOP
              super dispose THEN ;
        : null nil 0 new ;
        : # range i@ ;
        : atom? false ;
class;
\
\1 3 5 7 9 5 int new[] 5 array : lotus  ok
\lotus . [1,3,5,7,9] ok
\1 lotus @ . 3  ok
\cr 5 1 lotus ! lotus .

more latter - on this --- and where it's going ----

the Parrot and the Forth

Annoncement 2004 - pir perl , ( perl one pir two perl one pir two )
http://www.nntp.perl.org/group/perl.perl6.internals/2004/10/msg26380.html

Yes, and you might wonder - about what exactly all this means ---
Current details of course are available ---
and so - more details available ----


https://github.com/parrot/forth/commit/fe606b4ed478c1d21979d84b521b601ad7fd6fda

a preview of collector collector

So I have not yet completed an algorithm to search for the illusive
singleton in a collector collector --- but I have faith that it will
appear on the horizon --- Simply what I am trying to do is search
a succession of collectors --- ( 1.first elimate uniques til none found )
then eliminate the uniques - go back to  ) - find singletons - by searching
through each collector beginning with first value in first collector - and searching
for a duplicate - in another collector.

more from squareobj

the square object is evolving - to this creature :::::

\ sub square
\ https://groups.google.com/forum/#!topic/comp.lang.forth/_MAttQoY3pw
cr s" loading sub section squares " type
vbp collector : mycollector
object class square
     method check-terr1
     method check-terr2
     method check-terr3
     method check-blkn1
     method check-blkn2
     method check-blkn3
     method check-sq-1
     method check-sq-2
     method check-sq-3
     method check-sq-4
     method check-sq-5
     method check-sq-6
     method check-sq-7
     method check-sq-8
     method check-sq-9
     method check-sq

     method column-calc2
     method sq1-print
     method sq2-print
     method sq3-print
     method sq4-print
     method sq5-print
     method sq6-print
     method sq7-print
     method sq8-print
     method sq9-print

     method sq1-load
     method sq2-load
     method sq3-load
     method sq4-load
     method sq5-load
     method sq6-load
     method sq7-load
     method sq8-load
     method sq9-load
    
     method sq-load
     method init-sq-cycle  
     method next-square
     method square-get-anchor-row
     method square-get-anchor-row
     method square-get-anchor
     method row-no-inc
     method col-no-inc

     mthod next-cell-in-square
     method row-no-here@
     method col-no-here@

class;

square class squareobj

      cell var terr
      cell var blkn
      cell var col-no-here
      cell var line-no-here
      cell var col-no-anchor
      cell var line-no-anchor
      cell var board-addr-here
      cell var width-here
      cell var offset-here
      cell var sq-no
how :
: check-terr1 col-no-here @ < 3 if 1 terr ! then ;
: check-terr2 col-no-here @  3 6 within if 2 terr ! then ;
: check-terr3 col-no-here @ 6 9 within  if 3 terr ! then ;

: check-blkn1 line-no-here @ < 3 if 1 blkn ! then ;
: check-blkn2 line-no-here @ 3 6 within if 2 blkn ! then ;
: check-blkn3 line-no-here @ 6 9 within if 3 blkn ! then ;

: check-sq-1 terr @ 1 = if blkn @ 1 = if 1 else 0 then else 0 then ;

: check-sq-2 terr @ 1 = if blkn @ 2 = if 2 else 0 then else 0 then ;

: check-sq-3 terr @ 1 = if blkn @ 3 = if 3 else 0 then else 0 then ;

: check-sq-4 terr @ 2 = if blkn @ 1 = if 4 else 0 then else 0 then ;

: check-sq-5 terr @ 2 = if blkn @ 2 = if 5 else 0 then else 0 then ;

: check-sq-6 terr @ 2 = if blkn @ 3 = if 6 else 0 then else 0 then ;

: check-sq-7 terr @ 3 = if blkn @ 1 = if 7 else 0 then else 0 then ;

: check-sq-8 terr @ 3 = if blkn @ 2 = if 8 else 0 then else 0 then ;

: check-sq-9 terr @ 3 = if blkn @ 3 = if 9 else 0 then else 0 then ;

: check-sq col-no-here ! row-no-here !
     check-terr1
     check-terr2
     check-terr3
     check-blkn1
     check-blkn2
     check-blkn3    
     check-sq-1
     check-sq-2
     check-sq-3
     check-sq-4
     check-sq-5
     check-sq-6
     check-sq-7
     check-sq-8
     check-sq-9
        + + + + + + + + ;

: store-input-here mycollector store-input ;

: column-calc2 board-addr-here line-no-here @ width-here * + ;
\  offset-here
: sq1-print 3 0 ?do i line-no-here ! 3 0 ?do i column-calc2 + c@ emit loop loop ;
:  sq2-print 3 offset-here ! 3 0 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ emit loop loop ;
: sq3-print 6 offset-here ! 3 0 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ emit loop loop ;

: sq4-print 6 3 ?do i line-no-here ! 3 0 ?do i column-calc2 + c@ emit loop loop ;
:  sq5-print 3 offset-here ! 6 3 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ emit loop loop ;
: sq6-print 6 offset-here ! 6 3 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ emit loop loop ;

: sq7-print 9 6 ?do i line-no-here ! 3 0 ?do i column-calc2 + c@ emit loop loop ;
:  sq8-print 3 offset-here ! 9 6 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ emit loop loop ;
: sq9-print 6 offset-here ! 9 6 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ emit loop loop ;

: sq1-load 3 0 ?do i line-no-here ! 3 0 ?do i column-calc2 + c@ 42 <> if store-input-here then loop loop ;
:  sq2-load 3 offset-here ! 3 0 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ 42 <> if store-input-here then loop loop ;
: sq3-load 6 offset-here ! 3 0 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ 42 <> if store-input-here then loop loop ;

: sq4-load 6 3 ?do i line-no-here ! 3 0 ?do i column-calc2 + c@ 42 <> if store-input-here then loop loop ;
:  sq5-load 3 offset-here ! 6 3 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ 42 <> if store-input-here then loop loop ;
: sq6-load 6 offset-here ! 6 3 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ 42 <> if store-input-here then loop loop ;

: sq7-load 9 6 ?do i line-no-here ! 3 0 ?do i column-calc2 + c@ 42 <> if store-input-here then loop loop ;
:  sq8-load 3 offset-here ! 9 6 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ 42 <> if store-input-here then loop loop ;
: sq9-load 6 offset-here ! 9 6 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ 42 <> if store-input-here then loop loop ;

: square-load sq-no !   sq-no @ 1 = if sq1-load else
                        sq-no @ 2 = if sq2-load else
                        sq-no @ 3 = if sq3-load else
                        sq-no @ 4 = if sq4-load else
                        sq-no @ 5 = if sq5-load else
                        sq-no @ 6 = if sq6-load else
                        sq-no @ 7 = if sq7-load else
                        sq-no @ 8 = if sq8-load else
                        sq-no @ 9 = if sq9-load then
                         then then then then then then then then ;

: init-sq-cycle 1 terr ! 1 blkn ! ;

: next-square blkn @ 1 + 4 = if terr @ 3 < if terr @ 1 + terr ! 1 blkn ! then then ;

/ the following will return col-no and row-no of "top-left" cell -
/ based on blkn and terr
/ 1 1 = col1 row1
/ 1 2 = col4 row1
/ 1 3 = col7 row1
/ 2 1 = col1 row4
/ 2 2 = col4 row4
/ 2 3 = col7 row4
/ 3 1 = col1 row7
/ 3 2 = col4 row7
/ 3 3 = col7 row7

: square-get-anchor-row terr @ 1 = if 1 row-no-anchor ! else terr @ 2 = if 4 row-no-anchor ! else terr @ 3 = if 7 row-no-anchor ! then then then ;
: square-get-anchor-col blkn @ 1 = if 1 line-no-anchor ! else blkn @ 2 = if 4 line-no-anchor ! else blkn @ 3 = if 7 line-no-anchor ! then then then ;
: square-get-anchor square-get-anchor-col line-no-anchor @ col-no-here ! square-get-anchor-row row-no-anchor @ row-no-here ! ;
: row-no-inc row-no-here @ 1 + row-no-here ! ;
: col-no-inc col-no-here @ 1 + col-no-here ! ;

: next-cell-in-square row-no-inc row-no-here @  row-no-anchor @ - 3 = if row-no-anchor @ row-no-here ! col-no-inc then ;
: row-no-here@ row-no-here @ ;
: col-no-here@ col-no-here @ ;
: init cr s" creating squareobj " type ;


class;

Boo Hoo and more class

it's worth while to observere - some boo's and hoo's

 include oof.fs
object class bii
method bii
class;

bii class boo
method boo
how:
: bii cr s" bii " type cr ;
: boo cr s" boo " type cr ;
: init cr s" loading boo " type cr ;
class;

boo class boo-hoo
method boo-hoo
how:
: boo-hoo cr s" boo-hoo " type cr ;
: boo cr s" boo-hooo boo " type cr ;
: init cr s" loading boo-hoo " type cr ;
class;

Compromise --- the Big Lie

There was a time, when I was younger and more innocent, when I believed it would be possible for some guy to write a blog on forth and make it funny at the same time.
What I've discovered is that - forth - can be humorous - it some ways --- it's almost a genetic part of the language in some ways --- but that, for me, (really truly), a blog about forth can try to be funny some times, but if it's about forth - the sad truth is it can not be funny all the time --- there are serious issues -
for example, why didn't I do this on github ?  Speaking of which you have the following:

https://github.com/kt97679/itsy-linux

So from now on I'll not push it as so funny ----
I was looking for puking out your guts funny ----
and unfortunately --- this blog it not designed to encourage alcohol sales.

So for example - ( the forth code ( or forth compiler ) - actually in point of fact it is assembler code ) in two versions - one -- for " standard linux " which is coming more to be known as 'nix --- and dos. So I've run the code under dos -
( dos box -  http://www.dosbox.com/)  and successfully compiled it with nasm and gcc - actually I think the dos one is straight nasm
 ( -f bin ) .

Finally - I also got it to work under win32 - but unfortunately - it all seems to come appart at win64 ( interesting ) - because - I believe that to be connected to " architecture " ....

Anyway,  ---- ( I can't even think of anything funny right now ) --- there's more - on the sudoku solver - and - really - I will make an effort to get it to github.

more sudoku

I wonder if I doing this to save time ?

Anyway - here is some revisions to objects from before ---- no laughs ----
still incomplete -


\ collector.fs
cr s" loading collector.fs " type cr

include oof.fs

\  we reserve a set of memory locations to back
\  up the collection state at any given time :
\  this is passed to the collection object in init

create vbp 9 cells allot
create vbpx 9 cells allot

object class precollect
   method @1
   method !1
   method @2
   method !2
   method @3
   method !3
   method @4
   method !4
   method @5
   method !5
   method @6
   method !6
   method @7
   method !7
   method @8
   method !8
   method @9
   method !9
   method nextval@
   method nextval!
   method sv-next@
   method sv-next!
   method nv@
   method nv!
   method dump-collection
   method nextval-prt
   method reset-all
   method sv-nextval
   method reset-nextval
   method check-unique
   method store-input
   method backup-current
   method restore-current
   method nextvalinc
   method mode-set-1
   method mode-init
   method mode-get
   method mode-get-prt
   method mode-swt
class;

precollect class collector
     cell var v1
     cell var v2
     cell var v3
     cell var v4
     cell var v5
     cell var v6
     cell var v7
     cell var v8
     cell var v9
     cell var nextval
     cell var sv-next
     cell var inpv
     cell var dupr
     cell var lclvbp
     cell var lclvbpx
     cell var mode
     cell var fnd
how:

: @1 v1 @ ;
: !1 v1 ! ;
: @2 v2 @ ;
: !2 v2 ! ;
: @3 v3 @ ;
: !3 v3 ! ;
: @4 v4 @ ;
: !4 v4 ! ;
: @5 v5 @ ;
: !5 v5 ! ;
: @6 v6 @ ;
: !6 v6 ! ;
: @7 v7 @ ;
: !7 v7 ! ;
: @8 v8 @ ;
: !8 v8 ! ;
: @9 v9 @ ;
: !9 v9 ! ;

: nextval@ nextval @ ;
: nextval! nextval ! ;
: nextvalinc nextval@ 1 + nextval! ;
: sv-next@ sv-next @ ;
: sv-next! sv-next ! ;

: nv!  nextval@ 1 = if !1 else nextval@
                2 = if !2 else nextval@
                3 = if !3 else nextval@
                4 = if !4 else nextval@
                5 = if !5 else nextval@
                6 = if !6 else nextval@
                7 = if !7 else nextval@
                8 = if !8 else nextval@

                9 = if !9
                then then then then then then then then then ;

: nv@  nextval@ 1 = if @1 else nextval@
                2 = if @2 else nextval@
                3 = if @3 else nextval@
                4 = if @4 else nextval@
                5 = if @5 else nextval@
                6 = if @6 else nextval@
                7 = if @7 else nextval@
                8 = if @8 else nextval@

                9 = if @9
                then then then then then then then then then ;

: reset-nextval sv-next@ nextval! ;
: sv-nextval nextval@ sv-next! ;
: nextval-prt cr s" nextval = " type nextval@ . ;
: reset-all 10 1 ?do i nextval! 42 nv! loop 1 nextval ! ;
: dump-collection sv-nextval 10 1 ?do i nextval! nv@ dup 10 < if . else emit then s" - " type loop reset-nextval ;
: check-unique inpv !  0 dupr ! sv-nextval
                     10 1 ?do i nextval! nv@ inpv @ = if 1 dupr ! leave then loop
                        reset-nextval dupr @ ;

: store-input check-unique 0 = if inpv @ nv! nextval@ 1 + nextval! then ;
: backup-current-vpb sv-nextval 9 0 ?do i nextval! 1 + nv@ lclvbp nextval@ + ! loop reset-nextval ;

: restore-current-vpb sv-nextval 9 0 ? do i dup nextval! mode-get 0 = if lclvbp + @ else lclvbp + @ then nextvalinc nv! loop reset-nextval ;

: backup-current-vpbx sv-nextval 9 0 ?do i nextval! 1 + nv@ lclvbpx nextval@ + ! loop reset-nextval ;

: restore-current-vpbx sv-nextval 9 0 ? do i dup nextval! mode-get 0 = if lclvbpx + @ else lclvbpx + @ then nextvalinc nv! loop reset-nextval ;

: backup-current mode-get 0 = if backup-current-vpb else backup-current-vpbx then ;
: restore-current mode-get 0 = if restore-current-vpb else restore-current-vpbx then ;


: mode-set-1 1 mode ! ;
: mode-init  0 mode ! ;
: mode-get   mode @ ;
: mode-get-prt mode @ . ;
: mode-swt mode-get = 0 if mode-set-1 else mode-init then ;

: check-possible mode-init backup-current mode-set-1 restore-current nextval @ 1 - mode-int restore-current ;


: store-possible-lcl 1 fnd ! mode-init backup-current mode-set-1 restore-current np! nextval @ 1 + nextval ! backup-current mode-init restore-current ;

: find-possible-lcl 0 fnd ! 10 1 ?do i dup check-val ! nextval! nv@ check-val @ = if store-possible-lcl  then loop  ;


\ in order for find possible to work the mode of the object must change -
\ because - possible values end up in a different container -
\ to make this simpiliar a change must be made to the backup and restore ----
\  so that if the mode is 0 it goes to lclvbp and if 1 if goes to lclvbpx
\  initially in find possible the mode is 0 then you do a backup - then change mode to 1 store and do a backup - the mode 0 restore -
\  to sent things back.

: init lclvbpx ! lclvbp ! reset-all cr s" init collector " type cr ;



class;

cr s" collector class loaded " type cr

collector : mycollector1
collector : mycollector2
collector : mycollector3
collector : mycollector4
collector : mycollector5
collector : mycollector6
collector : mycollector7
collector : mycollector8
collector : mycollector9

collector class collectorcollector
   cell var collector-pointer
class;

itsy - with bitsy or without

Now this could be itsy ---

itsy has been the focus of my attention - maybe bitsy
but I'm talking about -

http://www.retroprogramming.com/2012/09/itsy-documenting-bit-twiddling-voodoo.html

https://plus.google.com/u/0/+JohnMetcalf/posts

There is a chance I'm getting my itsy and bitsy

confused

The posts or so my not be so humorous - in fact if this makes you laugh 

you might be in trouble - with the next couple

swizzling out

What is the last defense of a drowning man ?

So I am in a tight spot - but I just might be able
to swizzle my way out - as for example:

: swizzle ( a b -- a b a b )
                swap dup rot dup -rot ;

I was actually shocked when I wrote this, and
somewhat concerned, but I apparently survived.

Unfortunately there might be a simple forth word
that already does this which I don't know or a
very commonly used way of doing the above
which I don't know

And the prize goes to 2dup - which does the same thing
without all the " hoop la " ..

----- but all that aside,

you can go

swap 'in
and
dup 'in
and
rot 'in
and
dup 'in
and
not rot 'in

all night long ....

rot 'in not and not 'in rot 'in

all night long ( etc, etc ... )

( or even a pie in the face )
now I need sound ... as well ...

but in the end, friend it all ends up to be
just a big mess 'o 2dups .....

( Ooooooohh )

Not so funny?

I have to ask ()

why would anyone  REALLY believe
that a blog on forth could even be remotely funny.

I am glad you asked because it is of the unmost
concern for me.  How could that even be possible ?

I kind of grew up in a program till you bleed culture
and so --- I guess I find somethings absurd.

And in a way the absurd is funny sometimes.

Of course, I could just ask myself if I thought I was
being funny - and well, actually ----

Not so much.

You see the challenge ????

pie in the face funny

Well, those of you who are still laughing -- it has become obvious to me
without some visual happening

this will not make it --- ( visual like pictures ( you know ) )....

The following I think is serious if a bit confusing -----

https://groups.google.com/forum/#!topic/comp.lang.forth/_MAttQoY3pw


Now some more pie in the face::::

\ collector.fs
cr s" loading collector.fs " type cr

include oof.fs

\  we reserve a set of memory locations to back
\  up the collection state at any given time :
\  this is passed to the collection object in init

create vbp 9 cells allot

object class precollect
   method @1
   method !1
   method @2
   method !2
   method @3
   method !3
   method @4
   method !4
   method @5
   method !5
   method @6
   method !6
   method @7
   method !7
   method @8
   method !8
   method @9
   method !9
   method nextval@
   method nextval!
   method sv-next@
   method sv-next!
   method nv@
   method nv!
   method dump-collection
   method nextval-prt
   method reset-all
   method sv-nextval
   method reset-nextval
   method check-unique
   method store-input
   method backup-current
   method restore-current
   method nextvalinc
class;

precollect class collector
     cell var v1
     cell var v2
     cell var v3
     cell var v4
     cell var v5
     cell var v6
     cell var v7
     cell var v8
     cell var v9
     cell var nextval
     cell var sv-next
     cell var inpv
     cell var dupr
     cell var lclvbp
how:

: @1 v1 @ ;
: !1 v1 ! ;
: @2 v2 @ ;
: !2 v2 ! ;
: @3 v3 @ ;
: !3 v3 ! ;
: @4 v4 @ ;
: !4 v4 ! ;
: @5 v5 @ ;
: !5 v5 ! ;
: @6 v6 @ ;
: !6 v6 ! ;
: @7 v7 @ ;
: !7 v7 ! ;
: @8 v8 @ ;
: !8 v8 ! ;
: @9 v9 @ ;
: !9 v9 ! ;

: nextval@ nextval @ ;
: nextval! nextval ! ;
: nextvalinc nextval@ 1 + nextval! ;
: sv-next@ sv-next @ ;
: sv-next! sv-next ! ;

: nv!  nextval@ 1 = if !1 else nextval@
                2 = if !2 else nextval@
                3 = if !3 else nextval@
                4 = if !4 else nextval@
                5 = if !5 else nextval@
                6 = if !6 else nextval@
                7 = if !7 else nextval@
                8 = if !8 else nextval@

                9 = if !9
                then then then then then then then then then ;

: nv@  nextval@ 1 = if @1 else nextval@
                2 = if @2 else nextval@
                3 = if @3 else nextval@
                4 = if @4 else nextval@
                5 = if @5 else nextval@
                6 = if @6 else nextval@
                7 = if @7 else nextval@
                8 = if @8 else nextval@

                9 = if @9
                then then then then then then then then then ;

: reset-nextval sv-next@ nextval! ;
: sv-nextval nextval@ sv-next! ;
: nextval-prt cr s" nextval = " type nextval@ . ;
: reset-all 10 1 ?do i nextval! 42 nv! loop 1 nextval ! ;
: dump-collection sv-nextval 10 1 ?do i nextval! nv@ dup 10 < if . else emit then s" - " type loop reset-nextval ;
: check-unique inpv !  0 dupr ! sv-nextval
                     10 1 ?do i nextval! nv@ inpv @ = if 1 dupr ! leave then loop
                        reset-nextval dupr @ ;

: store-input check-unique 0 = if inpv @ nv! nextval@ 1 + nextval! then ;
: backup-current sv-nextval 9 0 ?do i nextval! 1 + nv@ lclvbp nextval@ + ! loop reset-nextval ;
: restore-current sv-nextval 9 0 ? do i dup nextval! lclvbp + @ nextvalinc nv! loop reset-nextval ;

: init lclvbp ! reset-all cr s" init collector " type cr ;

class;

cr s" collector class loaded " type cr

and more :

\ sub square

\ https://groups.google.com/forum/#!topic/comp.lang.forth/_MAttQoY3pw

object class square

     method check-terr1

     method check-terr2

     method check-terr3

     method check-blkn1

     method check-blkn2

     method check-blkn3

     method check-sq-1

     method check-sq-2 

     method check-sq-3 

     method check-sq-4 

     method check-sq-5

     method check-sq-6

     method check-sq-7

     method check-sq-8

     method check-sq-9

     method check-sq

     method column-calc2

     method sq1-print

     method sq2-print

     method sq3-print

     method sq4-print

     method sq5-print

     method sq6-print

     method sq7-print

     method sq8-print

     method sq9-print

     method sq1-load

     method sq2-load

     method sq3-load

     method sq4-load

     method sq5-load

     method sq6-load

     method sq7-load

     method sq8-load

     method sq9-load

     

     method sq-load

class;

square class squareobj

      cell var terr

      cell var blkn

      cell var col-no-here

      cell var line-no-here

      cell var board-addr-here

      cell var width-here

      cell var offset-here

      cell var sq-no

: check-terr1 col-no-here @ < 3 if 1 terr ! then ;

: check-terr2 col-no-here @  3 6 within if 2 terr ! then ;

: check-terr3 col-no-here @ 6 9 within  if 3 terr ! then ;

: check-blkn1 line-no-here @ < 3 if 1 blkn ! then ;

: check-blkn2 line-no-here @ 3 6 within if 2 blkn ! then ;

: check-blkn3 line-no-here @ 6 9 within if 3 blkn ! then ;

: check-sq-1 terr @ 1 = if blkn @ 1 = if 1 else 0 then else 0 then ;

: check-sq-2 terr @ 1 = if blkn @ 2 = if 2 else 0 then else 0 then ;

: check-sq-3 terr @ 1 = if blkn @ 3 = if 3 else 0 then else 0 then ;

: check-sq-4 terr @ 2 = if blkn @ 1 = if 4 else 0 then else 0 then ;

: check-sq-5 terr @ 2 = if blkn @ 2 = if 5 else 0 then else 0 then ;

: check-sq-6 terr @ 2 = if blkn @ 3 = if 6 else 0 then else 0 then ;

: check-sq-7 terr @ 3 = if blkn @ 1 = if 7 else 0 then else 0 then ;

: check-sq-8 terr @ 3 = if blkn @ 2 = if 8 else 0 then else 0 then ;

: check-sq-9 terr @ 3 = if blkn @ 3 = if 9 else 0 then else 0 then ;

: check-sq 

     check-terr1

     check-terr2

     check-terr3

     check-blkn1

     check-blkn2

     check-blkn3     

     check-sq-1

     check-sq-2

     check-sq-3

     check-sq-4

     check-sq-5

     check-sq-6

     check-sq-7

     check-sq-8

     check-sq-9

        + + + + + + + + ;

: column-calc2 board-addr-here line-no-here @ width-here * + ;

offset-here

: sq1-print 3 0 ?do i line-no-here ! 3 0 ?do i column-calc2 + c@ emit loop loop ;

:  sq2-print 3 offset-here ! 3 0 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ emit loop loop ;

: sq3-print 6 offset-here ! 3 0 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ emit loop loop ;

: sq4-print 6 3 ?do i line-no-here ! 3 0 ?do i column-calc2 + c@ emit loop loop ;

:  sq5-print 3 offset-here ! 6 3 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ emit loop loop ;

: sq6-print 6 offset-here ! 6 3 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ emit loop loop ;

: sq7-print 9 6 ?do i line-no-here ! 3 0 ?do i column-calc2 + c@ emit loop loop ;

:  sq8-print 3 offset-here ! 9 6 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ emit loop loop ;

: sq9-print 6 offset-here ! 9 6 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ emit loop loop ;

: sq1-load 3 0 ?do i line-no-here ! 3 0 ?do i column-calc2 + c@ 42 <> if store-input then loop loop ;

:  sq2-load 3 offset-here ! 3 0 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ 42 <> if store-input then loop loop ;

: sq3-load 6 offset-here ! 3 0 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ 42 <> if store-input then loop loop ;

: sq4-load 6 3 ?do i line-no-here ! 3 0 ?do i column-calc2 + c@ 42 <> if store-input then loop loop ;

:  sq5-load 3 offset-here ! 6 3 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ 42 <> if store-input then loop loop ;

: sq6-load 6 offset-here ! 6 3 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ 42 <> if store-input then loop loop ;

: sq7-load 9 6 ?do i line-no-here ! 3 0 ?do i column-calc2 + c@ 42 <> if store-input then loop loop ;

:  sq8-load 3 offset-here ! 9 6 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ 42 <> if store-input then loop loop ;

: sq9-load 6 offset-here ! 9 6 ?do i line-no-here ! 3 0 ?do i column-calc2 + offset-here @ + c@ 42 <> if store-input then loop loop ;

: square-load sq-no !   sq-no @ 1 = if sq1-load else

                        sq-no @ 2 = if sq2-load else

                        sq-no @ 3 = if sq3-load else 

                        sq-no @ 4 = if sq4-load else

                        sq-no @ 5 = if sq5-load else 

                        sq-no @ 6 = if sq6-load else

                        sq-no @ 7 = if sq7-load else 

                        sq-no @ 8 = if sq8-load else

                        sq-no @ 9 = if sq9-load then

                         then then then then then then then then ; 

class;

and even more ----

include oof.fs  

object class dum  

method prt  

class;  

object class dumb  

method prt2  

class;  

dum class dum-dum  

cell var rad  

how:   

: prt rad @ . ;  

: init rad ! ;  

class; 

25 dum-dum : mydumdum

dumb class dumber

how:

: prt2 cr s" dumber " type mydumdum prt ;

: init s" init  dumber " type ;

class;

if your not laughing with me -

then ? you must be laughing at me

incomplete untested forth sudoku solver

This is an incomplete, untested, and, un-commented, and undocumented
sudoku solver in forth.   Not only that but it's actually amusing if
you read between the lines.   Of course, that my cause you to experience
excruciating headaches and possibly hallucinations .......
Remember if you use this code and you or your computer or your
family or friends begin to experience " black outs " it is not the direct
responsibility of the author, his computer, his family or his friends.

and thanks for the fish ....


9 constant width
81 constant size
42 constant empty
variable board size allot
board size empty fill
( read file into buffer )
variable buff 1000 allot
0 Value fh
s" sud_puzzle1" r/o open-file throw to fh

buff 1000 fh read-file throw drop
fh close-file throw
: buff-to-board
    size 0 ?do
buff i + @ board i + ! loop ;

variable line-no


: board-fetch
    board width line-no @ * + ;



: print-line
     line-no !
    width 0 ?do
board-fetch  i +   c@ emit loop ;

: print-board
    cr
    width 0 ?do
i print-line cr loop ;

: test-aster 42 = if s" eq " type else s" not eq " type then ;


: check-sq-1 col-no @ 3 < and line-no @ 3 < if 1  else 0 then ;

: check-sq-2 col-no @ 3 < and line-no @ 3  6 within if 2  else 0 then ;

: check-sq-3 col-no @ 3 < and line-no @ 6  9 within if 3  else 0 then ;

: check-sq-4 col-no @ 3  6 within and line-no @ 3 < if 4  else 0 then ;

: check-sq-5 col-no @ 3  6 within and line-no @ 3  6 within if 5  else 0 then ;

: check-sq-6 col-no @ 3 6 within and line-no @ 6  9 within if 6  else 0 then ;

: check-sq-7 col-no @ 6  9 within and line-no @ 3 < if 7  else 0 then ;

: check-sq-8 col-no @ 6 9 within and line-no @ 3 6 within if 8  else 0 then ;

: check-sq-9 col-no @ 6 9 within and line-no @ 6 9 within if 9  else 0 then ;


variable terr
variable blkn

: check-terr1 col-no @ < 3 if 1 terr ! then ;
: check-terr2 col-no @  3 6 within if 2 terr ! then ;
: check-terr3 col-no @ 6 9 within  if 3 terr ! then ;

: check-blkn1 line-no @ < 3 if 1 blkn ! then ;
: check-blkn2 line-no @ 3 6 within if 2 blkn ! then ;
: check-blkn3 line-no @ 6 9 within if 3 blkn ! then ;

: check-sq-1 terr @ 1 = if blkn @ 1 = if 1 else 0 then else 0 then ;

: check-sq-2 terr @ 1 = if blkn @ 2 = if 2 else 0 then else 0 then ;

: check-sq-3 terr @ 1 = if blkn @ 3 = if 3 else 0 then else 0 then ;

: check-sq-4 terr @ 2 = if blkn @ 1 = if 4 else 0 then else 0 then ;

: check-sq-5 terr @ 2 = if blkn @ 2 = if 5 else 0 then else 0 then ;

: check-sq-6 terr @ 2 = if blkn @ 3 = if 6 else 0 then else 0 then ;

: check-sq-7 terr @ 3 = if blkn @ 1 = if 7 else 0 then else 0 then ;

: check-sq-8 terr @ 3 = if blkn @ 2 = if 8 else 0 then else 0 then ;

: check-sq-9 terr @ 3 = if blkn @ 3 = if 9 else 0 then else 0 then ;

: check-sq col-no ! line-no !
     check-terr1
     check-terr2
     check-terr3
     check-blkn1
     check-blkn2
     check-blkn3  
     check-sq-1
     check-sq-2
     check-sq-3
     check-sq-4
     check-sq-5
     check-sq-6
     check-sq-7
     check-sq-8
     check-sq-9
        + + + + + + + + ;


variable v1
variable v2
variable v3
variable v4
variable v5
variable v6
variable v7
variable v8
variable v9

variable vp1
variable vp2
variable vp3
variable vp4
variable vp5
variable vp6
variable vp7
variable vp8
variable vp9

: @1 v1 @ ;
: !1 v1 ! ;
: @2 v2 @ ;
: !2 v2 ! ;
: @3 v3 @ ;
: !3 v3 ! ;
: @4 v4 @ ;
: !4 v4 ! ;
: @5 v1 @ ;
: !5 v1 ! ;
: @6 v6 @ ;
: !6 v6 ! ;
: @7 v7 @ ;
: !7 v7 ! ;
: @8 v8 @ ;
: !8 v8 ! ;
: @9 v9 @ ;
: !9 v9 ! ;


: @p1 vp1 @ ;
: !p1 vp1 ! ;
: @p2 vp2 @ ;
: !p2 vp2 ! ;
: @p3 vp3 @ ;
: !p3 vp3 ! ;
: @p4 vp4 @ ;
: !p4 vp4 ! ;
: @p5 vp1 @ ;
: !p5 vp1 ! ;
: @p6 vp6 @ ;
: !p6 vp6 ! ;
: @p7 vp7 @ ;
: !p7 vp7 ! ;
: @p8 vp8 @ ;
: !p8 vp8 ! ;
: @p9 vp9 @ ;
: !p9 vp9 ! ;



variable nextval
variable sv-nextval
variable nextavailable
variable inpv
variable dupr

: nextval@ nextval @ ;
: nextval! nextval ! ;
: sv-nextval@ sv-nextval @ ;
: sv-nextval! sv-nextval ! ;


: nv!  nextval@ 1 = if !1 else nextval@
                2 = if !2 else nextval@
                3 = if !3 else nextval@
                4 = if !4 else nextval@
                5 = if !5 else nextval@
                6 = if !6 else nextval@
                7 = if !7 else nextval@
                8 = if !8 else nextval@

                9 = if !9
                then then then then then then then then then ;

: nv@  nextval@ 1 = if @1 else nextval@
                2 = if @2 else nextval@
                3 = if @3 else nextval@
                4 = if @4 else nextval@
                5 = if @5 else nextval@
                6 = if @6 else nextval@
                7 = if @7 else nextval@
                8 = if @8 else nextval@

                9 = if @9
                then then then then then then then then then ;

: nvp!  nextpval@ 1 = if !p1 else nextpval@
                2 = if !p2 else nextpval@
                3 = if !p3 else nextpval@
                4 = if !p4 else nextpval@
                5 = if !p5 else nextpval@
                6 = if !p6 else nextpval@
                7 = if !p7 else nextpval@
                8 = if !p8 else nextpval@

                9 = if !p9
                then then then then then then then then then ;

: nvp@  nextpval@ 1 = if @p1 else nextpval@
                2 = if @p2 else nextpval@
                3 = if @p3 else nextpval@
                4 = if @p4 else nextpval@
                5 = if @p5 else nextpval@
                6 = if @p6 else nextpval@
                7 = if @p7 else nextpval@
                8 = if @p8 else nextpval@

                9 = if @p9
                then then then then then then then then then ;


: reset-nextval sv-nextval@ nextval! ;
: set-sv nextval@ sv-nextval! ;

: check-unique inpv !  0 dupr ! set-sv
                     10 1 ?do i nextval! nv@ inpv @ = if 1 dupr ! then loop
                        reset-nextval dupr @ ;

: store-input check-unique 0 = if inpv @ nv! nextval@ 1 + nextval! then ;

: load-from-row
              line-no !
               width 0 ?do
          board-fetch  i +  c@ dup current-val ! 42 <> if current-val @  store-input then loop ;



variable offset

: column-calc line-no ! board line-no @ width * + ;

: column-calc2 board line-no @ width * + ;

: print-column cr offset ! board offset @ + c@ emit cr
    width 1 ?do i column-calc offset @ + c@ emit cr loop ;

: load-from-column offset ! board offset @ + c@ dup current-val ! 42 <> if store-input then
                    9 1 ?do i column-calc offset @ + c@ dup current-val ! 42 <> if store-input then loop ;

: sq1-print 3 0 ?do i line-no ! 3 0 ?do i column-calc2 + c@ emit loop loop ;
:  sq2-print 3 offset ! 3 0 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ emit loop loop ;
: sq3-print 6 offset ! 3 0 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ emit loop loop ;

: sq4-print 6 3 ?do i line-no ! 3 0 ?do i column-calc2 + c@ emit loop loop ;
:  sq5-print 3 offset ! 6 3 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ emit loop loop ;
: sq6-print 6 offset ! 6 3 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ emit loop loop ;

: sq7-print 9 6 ?do i line-no ! 3 0 ?do i column-calc2 + c@ emit loop loop ;
:  sq8-print 3 offset ! 9 6 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ emit loop loop ;
: sq9-print 6 offset ! 9 6 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ emit loop loop ;

: sq1-load 3 0 ?do i line-no ! 3 0 ?do i column-calc2 + c@ 42 <> if store-input then loop loop ;
:  sq2-load 3 offset ! 3 0 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ 42 <> if store-input then loop loop ;
: sq3-load 6 offset ! 3 0 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ 42 <> if store-input then loop loop ;

: sq4-load 6 3 ?do i line-no ! 3 0 ?do i column-calc2 + c@ 42 <> if store-input then loop loop ;
:  sq5-load 3 offset ! 6 3 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ 42 <> if store-input then loop loop ;
: sq6-load 6 offset ! 6 3 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ 42 <> if store-input then loop loop ;

: sq7-load 9 6 ?do i line-no ! 3 0 ?do i column-calc2 + c@ 42 <> if store-input then loop loop ;
:  sq8-load 3 offset ! 9 6 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ 42 <> if store-input then loop loop ;
: sq9-load 6 offset ! 9 6 ?do i line-no ! 3 0 ?do i column-calc2 + offset @ + c@ 42 <> if store-input then loop loop ;
variable sq-no
: square-load sq-no !   sq-no @ 1 = if sq1-load else
                        sq-no @ 2 = if sq2-load else
                        sq-no @ 3 = if sq3-load else
                        sq-no @ 4 = if sq4-load else
                        sq-no @ 5 = if sq5-load else
                        sq-no @ 6 = if sq6-load else
                        sq-no @ 7 = if sq7-load else
                        sq-no @ 8 = if sq8-load else
                        sq-no @ 9 = if sq9-load then
                         then then then then then then then then ;

: fill-constraints check-sq square-load col-no @ load-from-column line-no @ load-from-row ;
variable fnd
variable nextpval
: check-possible nextpval @ 1 - ;
: store-possible nvp! nextpval @ 1 + nextpval ! ;
: find-possible 0 fnd ! 10 1 ?do i dup check-val ! nextval! nv@ check-val @ = if 1 fnd ! then loop fnd @ 0 = if store-possible then ;
: store-cell board line-no + col-no 9 * + nvp@ ! ;
: load-cell  check-possible 1 = if store-cell then ;

--- a funny forth blog ---

" O - MOMMA - Can this really be the end ??????

to be stuck inside of Mobile with the Memphis Blues agian ???? "


Okay,  I am really going to try to use this blog appropriately for
forth --- or is it Forth ??? perl is Perl ----

Anyway,,,,, it might be somewhat limited - but I am for sure
trying to sort out some stuff --- ( very trying times )

-----

No ( forth ) now though ....  but this will be primarily 000 ans

no ( so forth and so on )