'2017-05-17 T 08:00:37

include "stringUtil.inc"


sys    sttw    'word position
sys    ascb    'word ascii code actual
sys    ascw    'word ascii code presented
sys    lenw    'word length
sys    opw     'operator token


function instrword(string s,k) as sys
===========================================
sys  lk=len k,lb,rb
byte b at strptr(s)
if not k then return 0
sys i=1
do
  i=instr(i,s,k)
  if i=0 then
    return 0
  end if
  lb=i-1
  rb=i+lk
  if b[rb]<33 then
    if i=1 or b[lb]<33
      return i
    end if
  end if
  i+=lk
end do
end function


function lookupindex(string s,k) as sys
=======================================
sys a
a=instrword(s,k)
if a then
  return valat a+len(k)+strptr s
end if
end function


macro instrab(mm,bb,bk,lk,  bt,bm,lm)
=====================================
byte bt=bb
byte bm at @bk
int lm=lk
mm=0
while lm
  lm--
  if bm=bt then mm=1 : exit while
  @bm++
wend
end macro


function instranyb(sys pb,pk, int ls,lk,i,di) as int
====================================================
if not ls then return 0
if i<0 then i+=ls+1
if i<0 then i=1
if i>ls then i=ls
if di=0 then di=1
if di>0 then
  if i=0 then i=1
  ls=ls-i+1
else
  if i=0 then i=ls
  ls=i
end if
int mm
byte *bb,*bk
@bb=pb+i-1
@bk=pk
while ls
  ls--
  instrab(mm,bb,bk,lk)
  if mm then return @bb-pb+1
  @bb+=di
wend
return 0
end function


function instrany(int i,string*s,*k) as int
===========================================
return instranyb(strptr(s),strptr(k), len(s), len(k), i, 1)
end function


function instrevany(int i,string*s,*k) as int
=============================================
return instranyb(strptr(s),strptr(k), len(s), len(k), i,-1)
end function


function instrb(byte*bb,*bk) as sys
===================================
sys b
do
  b=bb
  select bk
  case 0    : return 1
  case b    : 'match chars
  case else : return 0
  end select
  @bk++
  @bb++
end do
end function


function instrev(sys i,string s,k) as sys
=========================================
sys  a=asc k
sys  lk=len k
sys  ls=len s
if i<0 then i+=ls+1
if i=0 then
  i=ls
elseif i<0 then
  i=1
elseif i>ls then
  i=ls
end if
byte b at strptr s
byte c at strptr k
do
  if i<1 then exit do
  select b[i]
  case a : if instrb(b[i],c) then exit do
  end select
  i--
end do
return i
end function


function replace(string t,w,r) as string
========================================
'
sys a,b,lw,lr
string s=t
'
lw=len(w)
lr=len(r)
a=1
do
  a=instr(a,s,w)
  if a=0 then exit do
  s=left(s,a-1)+r+mid(s,a+lw)
  a+=lr
end do
return s
end function


'DEFAULT EQUATES
================
%% SymbolTerm     40,41,44
%% SymbolQuote    34,39,96
%% SymbolComment  59
%% SymbolEndLine  13,10,11,12
%% SymbolEndState 41


function skipspace(string s, sys*i)
===================================
byte b at strptr s
do
  ascb=b[i]
  ascw=ascb
  select ascb
  case 0              : exit do
  case SymbolEndState : ascw=0 : exit do
  case 33 to 255 :    : exit do
  end select
  i++
end do
end function


function skiplspace(string s, sys*i)
====================================
byte b at strptr s
do
  ascb=b[i]
  ascw=ascb
  select ascb
  case 0              : exit do
  case SymbolEndLine  : exit do
  case SymbolEndState : ascw=0 : exit do
  case 33 to 255      : exit do
  end select
  i++
end do
end function


function startline(string s, sys*i)
===================================
byte b at strptr s
do
  if i<2 then exit do
  select b[i]
  case 0             : exit do
  case SymbolEndLine : i++ : exit do
  end select
  i--
end do
end function


function endline(string s, sys*i)
=================================
byte b at strptr s
do
  select b[i]
  case 0             : exit do
  case SymbolEndLine : exit do
  end select
  i++
end do
end function


function nextline(string s, sys*i)
==================================
byte b at strptr s
do
  select b[i]
  case 0        : exit do 'END OF STRING
  case 10,11,12 : i++ : exit do
  case 13       : i++
    if b[i]=10 then i++
    exit do
  case else : i++
  end select
end do
end function


function GetNextLine(string s, sys *b) as string
================================================
if b=0 then b=1
int a=instr(b,s,cr)
if a then
  function=mid(s,b,a-b)
  b=a+2
end if
end function


function SameName(string a,b) as sys
====================================
if lcase(a) = lcase(b) then return -1
end function


macro posword(s,i)
==================
byte b at strptr s
'
rwordpos:
'
skipspace s,i
sttw=i
select ascb 'FIRST CHAR
case SymbolTerm
  i++ : jmp fwd nwordpos 'normally brackets    (  )
case 0
  jmp fwd nwordpos 'END
case SymbolQuote
  do
    i++
    select b[i]
    case 0    : jmp fwd nwordpos
    case ascw : i++ : jmp fwd nwordpos
    end select
  end do
  jmp fwd nwordpos
case SymbolComment
  endline(s,i) : jmp rwordpos      ' ;   comment ;
case 255
  i++ : opw=b[i] : i++ : jmp fwd nwordpos 'EMBEDDED TOKEN
end select
do 'MOVE TO WORD BOUNDARY
  select b[i]
  case 0 to 32
    exit do
  case SymbolTerm
    exit do
  case SymbolQuote
    exit do
  case SymbolComment
    exit do
  case 255
    exit do ' embedded token marker
  end select
  i++
end do
nwordpos:
lenw=i-sttw
end macro


function stepword(string s,sys*i) as sys
========================================
posword(s,i)
end function


function getword(string s, sys*i) as string
===========================================
posword(s,i)
return mid s,sttw,lenw
end function


function maygetword(string s, sys*i) as string
==============================================
skiplspace s,i
if ascb>32 then return mid s,sttw,lenw
end function


function getphrase(string s, sys *i) as string
'=============================================
sys a,j,le
le=len s
j=i
i--
do
  i++
  if i>le then exit do
  a=asc s,i
  if a=44 then continue do 'comma
  if a>32 then exit do     'non white space
end do
'
j=i
do
  if i>le then exit do
  a=asc s,i
  if a=44 then exit do  'comma
  i++
end do
'
if i>j then return mid s,j,i-j
'
end function


function isnumber() as sys
==========================
select ascb
case 47
case 45 to 57 :return -1
end select
end function


function isalpha() as sys
=========================
select ascb
case 0x41 to 0x5a : return -1
case 0x61 to 0x7a : return -1
case "_" : return -1
end select
end function



function stepitem(string sr, sys*i)
===================================
string wr
sys bc
stepword(sr,i)
if ascw<>40 then return 'skip the word only
'otherwiwise skip block including any nested blocks
bc++
do 'STEP OVER NESTED BRACKETS
  stepword(sr,i)
  select ascw
  case 0 :
    if ascb = 41 then
      if bc <= 0 then exit do
      bc--
    else
      exit do
    end if
  case 40 : bc++
  case 41 : bc--
  end select
  if bc=0 then exit do
end do
end function


function getitem(string sr, sys*i) as string
============================================
sys b,c
skipspace(sr,i)
b=i
c=ascw
stepitem(sr,i)
sttw=b
ascw=c
return mid sr, b, i-b
end function


function unquote(string s) as string
====================================
ascw=asc s
select ascw
case SymbolQuote 
  if asc(s,-1)=ascw then
    ascw=asc s,2
    return mid s, 2, len(s)-2
  end if
end select
return s
end function


function inner(string s) as string
==================================
sys i=1, le
'EFFECTIVE LEFT TRIM
skipspace(s,i)
'EFFECTIVE RIGHT TRIM
le=len(s)
byte b at le+strptr s
le=le-i+1
do
  if le<=0 then exit do
  @b--
  if b>32 then exit do
  le--
end do
'REMOVING OUTER SYMBOLS
le-=2
i++
if le>0 then return mid s,i,le
end function


'https://en.wikipedia.org/wiki/Escape_sequences_in_C
'
function EscSeq(string s) as string
===================================
string t=s
byte   b1 at strptr s
byte   b2 at strptr t
byte   c
sys    i, v
do
  c=b1
  select c
  case 0 : exit do
  case 92
    @b1++
    select b1
   'case "\","?","'",34
    case "n" : b2=13 : @b2++ : c=10 'new line
    case "a" : c=7  'beep
    case "b" : c=8  'backspace
    case "t" : c=9  'htab
    case "v" : c=11 'vtab
    case "f" : c=12 'form feed
    case "r" : c=13 'return
    case "e" : c=27 'esc
    case "x"        'hexadecimal asci value
      v=0 : i=0
      do
        i++ : if i>2 then exit do
        @b1++
        if b1<48 then @b1-- : exit do
        c=b1-48
        if c>9  then c-=7  'hex adjust
        if c>15 then c-=32 'hex lowercase
        select c
        case 0 to 15 : v=v*16+c
        case else : @b1-- : exit do
        end select
      end do
      c=v
      case  48 to 57 'octal ascii value
      v=b1-48 : i=1
      do
        i++ : if i>3 then exit do
        @b1++
        c=b1-48
        select b1
        case 48 to 55 : v=v*8+c
        case else     : @b1-- : exit do
        end select
      end do
      c=v
    end select
  end select
  b2=c
  @b1++
  @b2++
end do
return left t, @b2-strptr t
end function
'
'print escseq "Escape Sequences\n1\n2\n3\n\101\t\061\t\x4d\n"


function BlockData(string*s, int*i) as string
=============================================
skipspace(s,i)
byte b at i-1+strptr(s)
int lb,rb,d,e,k
def setb k=i+1 : d++
do
  select b
  case 0 : e=i : exit do
  case 1 to 31 : if not lb then e=i : exit do
  case "("  : if not lb then lb=40  : rb=41  : setb
  case "<"  : if not lb then lb=60  : rb=62  : setb
  case "["  : if not lb then lb=91  : rb=93  : setb
  case "{"  : if not lb then lb=123 : rb=125 : setb
  case lb   : d++ 'nesting
  case rb   : d-- : if d<=0 then e=i : i++ : exit do
  case else : if not k then k=i : lb=-1
  end select
  @b++
  i++
end do
skipspace(s,i)
if k then return mid(s,k,e-k)
end function


function ExtractData(string s,w, int i=1) as string
===================================================
  'format: $keyword lbracket data rbracket
  i=instr(i,s,w)
  if i then return BlockData(s,i+len(w))
end function


macro ReadNextItem(w,s,i,  b)
=============================
  int b=i
  do
    stepitem(s,i)
    select ascb
      case 0  : exit do
      case 44 : exit do
    end select
  end do
  w=mid(s,b,i-b-lenw)
end macro


macro split(s, d, max, n,  i,w)
===============================
's    string to be split
'd    array for the split data
'max  max number of elements in d
'n    count of elements split
scope
  indexbase 1
  int i = 1
  string w
  do
    ReadNextItem w,s,i
    if ascb=0 then exit do
    if n>=max then exit do
    n++
    d[n]=unquote(w)
  end do
end scope
end macro


macro join(d,e,b,g,t,  i,lw,p,w)
================================
'd  array of data
'e  count of elements to join
'b  left element markrker
'g  right element marker+delimiter
't  string for joined data
scope
  indexbase 1
  int    i,lw
  int    p=1
  string w
  t=""
  for i=1 to e
    w=b d[i] g 'autoconvert
    lw=len(w)
    if lw+p>=len t then t+=nuls 16000+lw 'stretch buffer
    mid t,p,w
    p+=lw
  next
  if len(g) then p--
  t=left t,p-1
end scope
end macro


class BufferObject
==================
  string prbuf
  sys    prpos,prblen, prslen, prquantum
  '
  method in(string s, n=-1) as sys
    prslen=len(s)
    if n>=0 then
      if n+prslen<=prblen then
        mid prbuf,n+1,s
        return 1
      end if
      return 0
    end if
    if prpos+prslen>prblen then
      if prquantum<=0 then prquantum=0x1000
      prbuf+=nuls prquantum + prslen*2 : prblen=len(prbuf)
    end if
    mid prbuf,prpos+1,s
    prpos+=prslen
    return 1
  end method
  '
  method empty()
    prblen=0 : prpos=0 : prbuf=""
  end method
  '
  method quantum(sys q)
    prquantum=q 'BUFFER EXTENSION STEP
  end method
  '
  method size() as int
    return prpos
  end method
  '
  method out(int oo=-1,le=-1) as string;
    if oo<0 then method=left prbuf,prpos : empty : exit method
    if le<0 then le=prpos
    if oo+le>prpos then le=prpos-oo
    return mid prbuf,oo+1,le
  end method
end class