needs hal/vreg lib/str lib/psrs lib/struct mem/range mem/reuse num/crc
unit text/diff

3 const CONTEXTSZ

struct Hunk {
  uint leftidx rightidx delcnt addcnt ;
}
Hunk typesz const HUNKSZ

code max[]= ( a1 u1 a2 u2 -- n )
  PSP) A>) @+, PSP) S>) @+, ( a1 u2 A=a2 S=u1 )
  S) &) <) if, S) &) !, then \ S=min-u
  0 i) S>) =) if, drop, 0 i) @, exit, then
  PSP) @, begin \ ( a1 a1 S=cnt A=a2 )
    A) R0>) @+, W) R0>) =) if, ( exitjmp )
    4 i) +, 1 i) S>) -, swap ?brnz, ( exitjmp ) then
  PSP) -, nip, 2 i) >>, exit,

code consume4[] ( a u n -- a u )
  S) &) !, drop, S) &) -, 2 i) S>) <<, PSP) dir) S>) +, exit,

: not0# ( n -- n ) dup not ?abort"something's wrong with lcs" ;
: lcs ( a1 u1 a2 u2 -- ?idx n-or-0 )
  2>r 2>r ( V1=a2 V2=u2 V3=a1 V4=u1 )
  V3 @ V1 V2 idx if ( idx )
    V1 V2 oover consume4[] ( idx a2+ u2- )
    2dup V3 V4 max[]= not0# >r ( idx a2+ u2- )
    1 consume4[]
    V3 rot> V4 rot> lcs ?dup if ( idx idx n )
      r> 2dup > if drop rot> + 1+ swap else nip nip then
      else r> then ( idx n ) not0#
    else 0 then
  2rdrop 2rdrop ;

create hunk HUNKSZ allot0
: hunk$ hunk HUNKSZ zfill ;
0 value lefta  0 value leftu
0 value righta 0 value rightu
: hunkleft[] lefta leftu hunk leftidx hunk delcnt + consume4[] ;
: hunkright[] righta rightu hunk rightidx hunk addcnt + consume4[] ;
: pushhunk ( ... n -- addcnt delcnt rightidx leftidx n+1 )
  4 0 do i 4* hunk + @ swap loop 1+
  hunk doto delcnt 0 | hunk doto leftidx + |
  hunk doto addcnt 0 | hunk doto rightidx + | ;
: ?pushhunk ( ... n -- ... n ) hunk delcnt hunk addcnt or if pushhunk then ;
: advance ( ... n n -- ... n )
  dip ?pushhunk | dup hunk doto leftidx + | hunk doto rightidx + | ;

: scandelete ( ... n -- ... n )
  begin hunk doto delcnt 1+ |
    hunkleft[] while @ hunkright[] idx not while repeat
    ( ... n idx ) drop else ( ... n a ) drop then ;
: addright ( ... n ltor-idx cnt -- ... n ) swap hunk to addcnt advance ;
: deleteleft ( ... n rtol-idx cnt -- ... n ) swap hunk to delcnt advance ;
code signed< ( a b -- f ) PSP) signed) <) bool, nip, exit,
: matchblocks ( ... n ltor-idx cnt rtol-idx cnt -- ... n )
  oover 4 dig - oover oover swap- ( leftscore rightscore )
  signed< if \ left-into-right block match wins, we add lines
    2drop addright else 2>r 2drop 2r> deleteleft then ;
: diffcrcs[] ( left u right u -- ... n )
  to{ lefta leftu righta rightu } hunk$
  0 begin hunkleft[] nip while ( ... n )
    hunkleft[] hunkright[] lcs ?dup if ( ... n idx cnt )
      over not if nip advance else
        hunkright[] hunkleft[] lcs ?dup if ( ... n idx cnt idx cnt )
          matchblocks else addright then then
    else scandelete then
  repeat
  hunkright[] nip ?dup if hunk to addcnt then ?pushhunk ;

: lines>crcs ( ... n a u -- ... n )
  dip dip dup if 1- swap else crc32$ then | | ( ... n crc a u )
  do[] ( ... n crc )
    i c@ dup LF = if drop crcdone swap 1+ crc32$ else acccrc then loop
  crc32$ over = if drop else swap 1+ then
  ps[] tuck swap[] ;

$400 ?reuse value buf
: ensurebuf ( n -- a ) Hunk typesz * buf swap ?realloc dup to buf ;

: diff[] ( left u right u -- a u )
  to{ righta rightu }
  0 rot> lines>crcs ps[] 2>r ( ... V1=leftcrc V2=lu )
  0 righta rightu lines>crcs ps[] 2>r ( ... ... V3=rightcrcs V4=ru )
  V1 V2 V3 V4 diffcrcs[] ( ... ... ... n )
  r! dup ensurebuf swap 0 do !+ !+ !+ !+ loop drop ( ... ... )
  V4 ndrop V2 ndrop ( )
  buf r> 2dup 4* swap[] 2rdrop 2rdrop ;


: ctxlo ( idx -- lo ) CONTEXTSZ - max0 ;
: hunkctx ( hunk -- lo hi ) A! leftidx dup ctxlo swap A> delcnt + CONTEXTSZ + ;
: grouphunks ( a u -- a u n )
  0 begin 1+ 2dup > while ( a u n )
    oover dup hunkctx nip ( a u n a hi )
    swap oover HUNKSZ * + hunkctx drop ( a u n hi lo )
    >= while repeat then ;

: lfidx ( a u -- a u ?idx f ) LF oover oover cidx ;
: skipline ( a u -- a u ) lfidx if 1+ else dup then consume[] ;
: skiplines ( a u n -- a u ) 0 do skipline loop ;
: .lines ( a u n prefix -- a u )
  >r 0 do ( a u V1=prefix )
    V1 emit lfidx if oover swap else 2dup then rtype nl> ( a u )
    skipline loop rdrop ;

: totcnts ( a u n -- a u n cntdelta )
  oover >A 0 oover 0 do ( a u n cntdelta A=a )
    A> delcnt - A> addcnt + HUNKSZ A+ loop ;
: .hunks ( a u n -- a u n )
  ."@@ -" oover hunkctx over 1+ . ( a u n lo hi )
  ."," swap- 1- r! . ( a u n V1=origcnt )
  ." +" oover rightidx ctxlo 1+ .
  ."," totcnts r> + . ." @@\n" ;

0 value lefti 0 value righti
: advanceleft ( to -- by ) doto lefti over | - max0 ;
: advanceright ( to -- by ) doto righti over | - max0 ;

: .diff[] ( left u right u -- )
  4 ndup diff[] ( left u right u a u )
  2>r 0 0 to{ lefta leftu righta rightu lefti righti } 2r> ( a u )
  begin ?dup while grouphunks ( a u n )
    .hunks
    oover lefta leftu rot leftidx ctxlo advanceleft skiplines to{ lefta leftu }
    0 do ( a u )
      over leftidx advanceleft ?dup if ( a u by )
        lefta leftu rot SPC .lines to{ lefta leftu } then
      over delcnt ?dup if ( a u cnt )
        dup doto lefti + | lefta leftu rot '-' .lines to{ lefta leftu } then
      over addcnt ?dup if ( a u cnt )
        oover rightidx advanceright ( a u cnt skipcnt )
        righta rightu rot skiplines to{ righta rightu } ( a u cnt )
        dup doto righti + |
        righta rightu rot '+' .lines to{ righta rightu } then
      1- swap HUNKSZ + swap loop repeat drop ;