fractions

// file factor.seq sept 19th 1994 2566 bytes
 variable flagx
 variable x

CODE /MOD_swap     \ puts the remainder on top
  POP     BX       \ instead of /mod swap
  POP     AX
  CWD
  MOV     CX, BX
  XOR     CX, DX
  JS      1 $
  IDIV    BX
  PUSH    aX
  PUSH    dX
  ES:
  LODS    WORD
  JMP     AX
 1 $: IDIV    BX
  OR      DX, DX
  JE      2 $
  ADD     DX, BX
  DEC     AX
 2 $: PUSH    aX
  PUSH    dX
  next
  end-code


: get-nth-prime  ( N -- NTHPRIME )

       2*
       prime-array
       +
       @ ;

: is-prime?     ( n -- n flag )
        flagx 0!                  \ set up flagx temp. varaible
        prime-array @ 1+          \ get count
                    1 do
                        i get-nth-prime
                        over =  ?dup if flagx !  \ store flag in flag x
                                        leave
                                     then
                     loop
       flagx @ ;


: (factor)  ( n0 -- n1 n2 n3 ... count )
\ this might be better recursive?
     x !            \ store number into X
     depth >r       \ store depth to calculate number of factors
      begin
           prime-array @ 1+
           1 do
                x @     \ get number
                i get-nth-prime
                /mod_swap    \ qout rem
                0=      if           \ even division, a factor
                          x !               \ store qout in x
                          i get-nth-prime   \ put it on the stack
                          leave
                        then
               drop
             loop
              x @ 1 =
              until
                depth
                r>
                - ;

\  the word above doesn't work for negatives, also 0
\  fix for negatives is important,
:  factor   ( n -- n1 n2 n3 ... count )
   dup
      0<
        if
          -1 swap abs (factor) 1+
          \ would a divide work better?
        else
          (factor)
        then ;

: *loop  ( x1 x2 x3 ... n -- y )  \ unfactor
        1 ?do
            *
          loop ;

 ' *loop alias unfactor

: **     ( n1 n2 -- n1^n2 )

   ?dup 0=
         if drop 1
         else
            dup 1 =
                   if drop
                   else
                       over swap 1-
                                  0 do
                                        over *
                                    loop
                                    nip
                  then
        then ;

// end of file ****
// file matrix.seq oct 10 1994 5169 bytes
\ Words for matrices
\ going to use abreviation Mx for matrix
  0  value v1
  0  value v2
\ this might to well as its own vocabulary

\  matrix should look like  header-- c r --c*r2words

: 4* 2* 2* ;

\ vocabulary <matrix>
\ also <matrix> definitions


\ upperleft corner is (1,1)

: matrix ( r c --  | Matrix-name )  \ actually creates a double matrix
                                     \ which I can use for a Frac matrix


  create                \ create the header for matrix-name
  2dup
  *
  >r                    \ store the number of elements on the Return Stack
  here c!            \ place #of columns as a byte, offset +0
  here 1+ c!               \ place #of rows as a bytes, offset +1
                \ ok now allocate the necessary bytes
  r>            \ Row*col
  4*         \ number of double-words needed
  2+            \ one more word for the first 2 bytes.
  allot
        does>         \ Matrix-name will do this on execution
                      \ matrix-name  ( --- address )
        2+            \ start address of matrix
        ;

: @dim-of-Mx  ( maddr -- max-row max-col )
    dup
    1- c@
    swap
    2- c@
    ;

: mcols@Mx  ( maddr -- max-col )
    2- c@
    ;

: ij>term#   ( i j max-cols -- term# )

         \ term# = max-cols(i-1)+j
         rot
         1-
         *
         +
         1-
         ;

: entry@     ( i j maddr -- entry )
     \ not doing any error checking
      dup>r
      mcols@Mx
      ij>term#
      4*
      r>
      + frac@ ;

 variable <mcol>

: init-mcol  ( -- )

  <mcol> 0!
  ;

: update-mcol  ( width -- )

  <mcol> @
  max                       \ leave the greater of the two
  <mcol> !                  \ and store it
  ;

: is-integer?   ( num den -- num den flag )   \ true when denominator = 1
  dup 1 = ;

: entry-width ( num den -- width )

  is-integer?    \ is entry a integer?
         if
           drop           \ drop the 1
           number-of-digits
         else
           number-of-digits
           swap number-of-digits
           + 1+
         then
   ;

: (.entry)
  is-integer?
             if
               drop .
             else
               ./
             then
  ;

: .entry   ( i j maddr -- )
     entry@
     2dup
     entry-width
     update-mcol
     (.entry)
     ;

: entry!    ( num den i j maddr -- )
      dup>r
      mcols@Mx
      ij>term#   ( -- value term# )
      4*
      r>
      + frac! ;

\ value for inner loop limit
  2 value L.1
  0 value v3
\  0 value addr.1

: fill-Mx   ( num den maddr -- )
  dup
  @dim-of-Mx
  \ * 4* fill  no 32-bit fill equivalent ( yet )
  1+ =: l.1
  1+ 1 do
         l.1 1 do
                3dup
                j i
                rot
                entry!
              loop
         loop
  3drop
  ;
: make-zero   ( maddr -- )
  0 1 rot
  fill-Mx
  ;

: make-identity  ( maddr -- )
  =: v1
  v1 make-zero        \ make the Mx all zeros
  v1 mcols@Mx     \ get the width of Mx.
  1+ 1 do
          1 1 i i v1 entry!
        loop
    ;
 2variable z

: Mx*scalar ( maddr num den  -- ) \ change Mx to Mx * scalar
  z frac!
   =: v1
  v1  @dim-of-Mx
   1+ =: l.1
   1+ 1 do                             \ outer loop = row
         l.1 1 do                      \ inner loop = column
                j i v1 entry@
                    z frac@
                    frac*
                j i v1 entry!          \ thus j = row i = col
              loop
        loop
   ;

: Mx*integer ( maddr integer -- )
  1 Mx*scalar ;

2variable scalar

: scalar*Mx+Mx    ( maddr1 maddr2 -- )    \ add maddr1 maddr2 =: mx1
       =: v2              \ matrix 2
       =: v1              \ matrix 1
   v1 @dim-of-mx
       1+ =: l.1
       1+ 1 do
               l.1 1 do
                        j i v2 entry@       \ get entry from matrix.2
                        j i v1 entry@       \ get entry form matrix.1
                        scalar frac@        \ fetch the value for scalar
                        frac*               \ scalar * matrix.1's entry
                        frac+
                        j i v1 entry!       \ set result to matrix.1 entry
                     loop
            loop
       ;
: Mx+mx          ( maddr1 maddr2 -- )   \  mx1 := mx1 + mx2
   1 1 scalar frac!  \ set scalar to 1
  scalar*mx+mx
  ;
: -mx+mx          ( maddr1 maddr2 -- )

  -1 1 scalar frac!  \ set scalar to -1
   scalar*mx+mx
   ;

: mx-mx
  swap -mx+mx ;

: display-Mx    ( maddr -- )
    at?
       =: v2               \ v1=col v2=row
       =: v1
   init-mcol
    dup
    @dim-of-Mx
    1+ =: l.1              \ save columns for inner loop
     1+ 1 do
            v2 =: v3
            l.1 1 do
                      incr> v3         \ increase the row
                      v1 v3 at
                  i j pluck .entry
                  loop
            <mcol> @ 1+ +!> v1  \ increase the columns by max width of entries
          loop
          drop
          ;

 3 3 Matrix r3
 ' display-mx alias .mx


// file stack.seq
\ stack manipulating words

code unfold     ( a b -- a a b )   \ equalivalent to over swap
pop bx            \ analogous to pulling on the top of the stack
pop ax            \ and having the second term "unfold" creating a duplicate
push ax           \ of itself to fill the place.
push ax
push bx
next
end-code


 code make-within  ( test-value min max -- value )
      pop cx        \ max value
      pop bx        \ min value
      pop ax        \ test value
    cmp ax, cx
    jng here 6 +
     push cx        \ test-value is passed through if
     next           \ it less than max and greater than min
    cmp ax, bx      \ if tv > max  then max is returned
    jnl here 6 +    \ if tv < min  then min is returned
     push bx
     next
    push ax
    next
    end-code

// end of file ****
// math.seq
\ math words

: r/ swap over /mod swap 2* rot / + ;  \ rounded division, good for integers

code u/mod          ( num den -- umod uquot )
pop bx
pop ax
xor dx, dx
div bx      \  dx:ax / bx -- dx=mod ax=quot
push dx
push ax
next
end-code

: umod         ( num den -- umod )
u/mod drop ;

: u/           ( num den -- uquot )
u/mod nip ;


 : calc_sum  \ ( ... #(n-1) #n n -- sum )  \ takes n single#s from the stack
                                           \ and finds the sum.
     1 ?do
           +
       loop
     ;

  : Dcalc_sum
     1 ?do
           d+
        loop
      ;

  : Dcalc_mean
      dup>r
         Dcalc_sum
      r>
      mu/mod nip ;

  : MCalc_sum

             0. z 2!     \ init temp 2var Z
                0 ?do
                     s>D    \ convert number to double
                     z D+!  \ add to Z
                  loop
                z 2@
                ;
  : MCalc_mean
           dup>r
                MCalc_sum
           r>
           M/mod nip ;



 : calc_mean \  ( ... #(n-1) #n n -- mean ) \ takes n singles from the stack
                                            \ and calculates the mean
    dup>r
        calc_sum
    r>
    /
    ;




// end of file ****
// frac.seq 6197 bytes sept 18 1994
\ Fraction math  should support single numbers and signs

  0 value V1
  0 value V2

\  need a symbol to use for all these types of operations
\  fractions are rational numbers, or ratios so maybe ":"
\
\  format for ":"numbers (rational) numerator denominator
\
\  question: which should carry the sign?
\
\            probably the numerator


: :.     ( num1 den1 -- )               \ display fractional number
     swap
     (.) type
     ." /"
     .
   ;
\ going to need a word called simplify which will need
\ to factor a number

: :uncommon-factor      ( n1 n2 -- uf1 uf2 )
\ actually this is comming out uf2 uf1 ?
\ uf1 will be what n2 has that n1 doesn't have

            2dup
                0<
                swap
                0<
                and
                if
                        swap abs
                        swap abs

                then
            2dup
                 abs =: v2
                 abs =: v1
                \ store n's into the values v1 & v2
            factor
                \ this will factor n2, leaving a result much like
                \ the root level of a factor tree, with a count
                \ on top
            0 ?do
                v1
                \ 1st pass this will be n1
                swap
                /mod
                \ divide by a factor of n2,
                \ remember n2's factors are on the stack
                swap
                \ I want the remainder on top, I'm going to use
                \ it as a Flag for if
                if
                        \ _if_ will see a nonzero as a true
                        \ so anything that doesn't divide
                        \ evenly will go this way
                        \ (uncommon-factors)
                        drop
                        \ these aren't factors so I don't
                        \ want them
               else
                        \ factors will have a mod. of 0
                        \ which is false
                        =: V1
                        \ I want to store the qoutient
                        \ (the other factor)
                        \ into
               then
            loop
            factor   \ now do the same thing for n1
            0 ?do
                v2
                swap
                /mod
                swap
                        if
                          drop
                        else
                          =: v2
                        then
             loop
           \  v1 v2    this is confusing at times
            v2 v1      \ this might be better

           \ ok what's left
           \ v1 will have in it the product of any of its factors
           \ that are uncommon with with n2
           \ v2 will all of n2's factors that are uncommon with n1'
;

comment:
 some examples: 12 36 :uncommon-factors ==> 1 3
                13 17 :uncommon-factors ==> 13 17
 basically this word works the way I handle fractions, common-factors
 are dropped, or ignored and the leaving the uncommons
   12 = 2*2*3
   36 = 2*2*3*3
comment;

' :uncommon-factor alias :reduce1

: :no-neg-denom
  \ don't won't negatives in the denominator
  \ num dem
  dup 0<
        if
          swap negate
          swap abs
        then
    ;

\ I'm wondering if I should do some try some simple division first.
: :reduce2
         2dup
         /mod
         swap
         if drop
            :reduce1
         else
         \ this means num is divisible by the denominator
         -rot
         2drop
         1
         then
   ;
: :reduce3
         2dup > if :reduce2
                else
                 2dup
                 swap
                 /mod
                 swap
                     if
                     drop
                     :reduce1
                     else
                     >r
                     2drop
                     1
                     r>
                     then
               then
    :no-neg-denom
    ;

defer :reduce

' :reduce3 is :reduce


: :+    ( num1 den1 num2 den2 -- num3 den3 )
  pluck     \ num1 den1 num2 den2 den1
  over      \ num1 den1 num2 den2 den1 den2
  :uncommon-factor  \ num1 den1 num2 den2 uf1 uf2
  swap
  swap >r           \ num1 den1 num2 den2 uf2
  drop *                 \ num1 den1 p2      \r uf1
  rot                    \ den1 p2 num1      \r uf1
  r@ *                   \ den1 p2 p1        \r uf1
  +  swap                \ num3 den1         \r uf1
  r> *                   \ num3 den1
  \ :reduce
  ;
comment:
            a    d        ae    db        ae + db
           __ +  __  =    ___ + ___   =   _______
           bc    ce       bce   bce        bce

comment;








comment:
:  :+        ( num1 den1 num2 den2 -- num3 den3 )
   rot                  \ num1 num2 den2 den1
   :uncommon-factor     \ let's see we have   num1 num2 uf1 uf2
   2dup * abs >r            \ the common denominator is a product of the
                        \ uncommon-factors, store it it's the c-d
                        \ num1 num2 uf1 uf2
   rot                  \ num1 uf1 uf2 num2
   *                    \ num1 uf1 p2
  -rot                  \ p2 num1 uf1
  *                     \ p2 p1
  +                     \ p2+p1
  r>                    \ p2+p1 c-d    -- back in fraction form
  :reduce
  ;
comment;

: :negate    ( a b -- -a b )  \ negate the fraction on top
   >r
   negate
   r>
   ;

: :-        ( num1 den1 num2 den2 -- num3 den3 )
  :negate
  :+
  ;

: :*       ( num1 den1 num2 den2 -- num3 den3 )

  rot
  *        \ num1 num2 den3
  >r       \ num1 num2
  *        \ num3
  r>       \ num3 den3
  :reduce
  ;

: :/
   swap :* ;



\s
0 value v3
0 value v4

: test-it
  time-reset
         =: v3
         =: v4
         5000 0
               do
                 v3 v4 :reduce 2drop
               loop
  .elapsed



// end of file ****
// syntax error above, missing closing semicolon
// file fraction.seq 6219 bytes Mar 8 2020
\ Fraction math  should support single numbers and signs

  0 value fc1
  0 value fc2

  ' 2variable alias frac-variable
  ' 2@        alias frac@
  ' 2!        alias frac!



\ code /mod_swap

: ./   ( num1 den1 -- )               \ display fractional number
     swap
     (.) type
     ." /"
     .
   ;
\ going to need a word called simplify which will need
\ to factor a number

: uncommon-factors      ( n1 n2 -- uf1 uf2 )
\ actually this is comming out uf2 uf1 ?
\ uf1 will be what n2 has that n1 doesn't have

            2dup
                0<
                swap
                0<
                and
                if
                        swap abs
                        swap abs

                then
            2dup
                 abs =: fc2
                 abs =: fc1
                \ store n's into the values fc1 & fc2
            factor
                \ this will factor n2, leaving a result much like
                \ the root level of a factor tree, with a count
                \ on top
            0 ?do
                fc1
                \ 1st pass this will be n1
                swap
                /mod_swap
                \ divide by a factor of n2,
                \ remember n2's factors are on the stack
                \ I want the remainder on top, I'm going to use
                \ it as a Flag for if
                if
                        \ _if_ will see a nonzero as a true
                        \ so anything that doesn't divide
                        \ evenly will go this way
                        \ (uncommon-factors)
                        drop
                        \ these aren't factors so I don't
                        \ want them
               else
                        \ factors will have a mod. of 0
                        \ which is false
                        =: fc1
                        \ I want to store the qoutient
                        \ (the other factor)
                        \ into
               then
            loop
            factor   \ now do the same thing for n1
            0 ?do
                fc2
                swap
                /mod_swap
                        if
                          drop
                        else
                          =: fc2
                        then
             loop
             fc1 fc2
           \ ok what's left
           \ fc1 will have in it the product of any of its factors
           \ that are uncommon with with n2
           \ fc2 will have all of n2's factors that are uncommon with n1'
            ;

comment:
 some examples: 12 36 :uncommon-factors ==> 1 3
                13 17 :uncommon-factors ==> 13 17
 basically this word works the way I handle fractions, common-factors
 are dropped, or ignored and the leaving the uncommons
   12 = 2*2*3
   36 = 2*2*3*3
comment;

: frac-defined?  ( frac1 -- frac1 true ; false )
  dup
  0= if
       2drop
       false
      else
       true
      then
  ;

: no-neg-denominator
  \ don't want negatives in the denominator
  \ num dem
  dup 0<
        if
          swap negate
          swap abs
        then
    ;

: simplify-frac
        over 0= if drop 1 \ convert to 0/1 if 0/n
                else
                   uncommon-factors
                   no-neg-denominator
                then
                ;
: reduce-frac
       2dup
       mod
          if 2dup
             swap
             /mod_swap if
                         drop
                       else
                         >r
                         2drop
                         1
                         r>
                       then
          else
          / 1
          then
          simplify-frac
        ;

\ I'm not going to worry anymore about speed for now
\ may be look at this again after matrices are done.

: frac+    ( num1 den1 num2 den2 -- num3 den3 )
  pluck
  over      \ num1 den1 num2 den2 den1 den2
  uncommon-factors  \ num1 den1 num2 den2 uf1 uf2
  >r
  >r
  rot               \ num1 num2 den1 den2       \r uf2 uf1
  2swap             \ den1 den2 num1 num2
  1 rpick           \ den1 den2 num1 num2 uf2
  *                 \ den1 den2 num1 p2
  swap              \ den1 den2 p2 num1
  r@  *             \ den1 den2 p2 p1
  +                 \ den1 den2 num3
  -rot              \ num3 den1 den2           \r uf2 uf1
  r>drop
  nip
  r>                \ num3 den2 uf2, this product ( or den1 uf1 )
  *                 \ will be the least common denonimator
  reduce-frac
  ;
comment:
            a    d        ae    db        ae + db
           __ +  __  =    ___ + ___   =   _______
           bc    ce       bce   bce        bce

comment;

: negate-frac    ( a b -- -a b )  \ negate the fraction on top
   >r
   negate
   r>
   ;

: frac-        ( num1 den1 num2 den2 -- num3 den3 )
  negate-frac
  frac+
  ;

: frac*       ( num1 den1 num2 den2 -- num3 den3 )

  rot
  *        \ num1 num2 den3
  >r       \ num1 num2
  *        \ num3
  r>       \ num3 den3
  reduce-frac
  ;

: frac/
   swap frac* ;

: calc-center-offset  ( width max-range -- offset )
 \ it should follow this formula
 \        M - (M+W)/2 = offset
 dup
 rot
 +
 2/
 -
 ;

: number-of-digits    ( n -- width )
 dup
    abs
       17 1 do
                base @ / dup
                        0= if
                             drop
                             i
                           leave
                           then
            loop
 swap 0< if 1+ then
 ;

: .C      ( n l -- )
   >r
   dup
   number-of-digits
   r@ calc-center-offset
   dup>r
   spaces
   .
   r>
   r>
   - abs 1- spaces ;
   \     ^
   \     |
   \     -- dot will leave an extra space

: bars  ( n -- )
     0 ?do
           ." �"
       loop ;

  5 value .frac-digits    \ number of digits to allow for
                          \ in the next word

: .frac       ( num1 den  -- )
  at? 2dup 2>r
  1+ at
  .frac-digits .c
  2R@ 1- at
  .frac-digits .c
  2r> at
  .frac-digits bars
  ;


// end of file ****