/* AnnotatedText Parser --
   Takes an annotated text string, parses it into instructions for printing,
    and prints it to the display.

   Blanks-per-indent and color/background print attributes are shared at
   the class level.  This allows for easy user setability.

   See ANOTEXT.H for encodings.
 */!!

inherit(Object, #ATParser, #(inputString
inPos     /* index into inputString */
outPos   /* char position of output */
maxPos /* max index in inputString */
q1          /* 1st priority instruction queue */
q2          /* 2ndt priority instruction queue */
c            /* inputString[inPos] during parse */
), 2, nil)!!

setClassVars(ATParser, #($blanksPerIndent
$backgroundFieldSet
$fieldColorDict
))!!

now(class(ATParser))!!

/* PUBLIC */
Def $backgroundFieldSet(self, val)
{ ^$backgroundFieldSet }
!!

/* PUBLIC */
Def $fieldColorDict(self)
{ ^$fieldColorDict }
!!

/* PUBLIC */
Def blanksPerIndent(self)
{ ^$blanksPerIndent }
!!

/* PUBLIC */
Def new(self, aString | anObj)
{ /* reset text color */
  $fieldColorDict[#plainText] := Call GetSysColor(COLOR_WINDOWTEXT) ;
  $fieldColorDict[AT_TYPE_NAME_FIELD] := $fieldColorDict[#plainText] ;


  anObj := new( self:ancestor ) ;
  ^init( anObj, aString ) 
}
!!

/* PUBLIC */
Def setBlanksPerIndent(self, val)
{ ^($blanksPerIndent := val) }
!!

now(ATParser)!!

/* PRIVATE 
   While ascii input chars, note position & move outPos.  
   Output plain-text instruction to q2.
   @@ should skip blanks @@
*/
Def doAscii(self | printInstruction)
{/* break("begin doAscii"); */
                          /* 0=type, 1=outStart, 2=inStart, 3=inEnd */
  printInstruction := tuple( #plainText, outPos, inPos, inPos ) ;
  inPos  := ( inPos  + 1 ) ;
  outPos := ( outPos + 1 ) ;
   
  loop while (inPos <= maxPos)
  begin 

    c := inputString[ inPos ] ;

    if ( (asInt(c) bitAnd AT_SPECIAL_MASK) = 0 )
    then
      inPos  := ( inPos  + 1 ) ;
      outPos := ( outPos + 1 ) ;
    else
      printInstruction[3] := ( inPos - 1 ) ; 
      /* enqueue */
      push( q2, printInstruction ) ;
      /*  break("end doAscii"); */
      ^self  /* typical exit */
    endif ;
     
   endLoop ;

   /* (inPos > maxPos): end of input is ok too */
   printInstruction[3] := ( inPos - 1 ) ; 
   push( q2, printInstruction ) ;
  
/*  break("end doAscii"); */
}
!!

/* PRIVATE 
   While ascii input chars, note position & move outPos.  
   Output field instruction to q2.
*/
Def doAsciiField(self, fieldType | printInstruction)
{/* break("begin doAsciiField"); */
                       /* 0=type, 1=outStart, 2=inStart, 3=inEnd */
  printInstruction := tuple( fieldType, outPos, inPos, inPos ) ;
  inPos  := ( inPos  + 1 ) ;
  outPos := ( outPos + 1 ) ;
   
  loop while (inPos <= maxPos)
  begin 

    c := inputString[ inPos ] ;

    if ( (asInt(c) bitAnd AT_SPECIAL_MASK) = 0 )
    then
      inPos  := ( inPos  + 1 ) ;
      outPos := ( outPos + 1 ) ;
    else
      printInstruction[3] := ( inPos - 1 ) ; 
      /* enqueue */
      push( q2, printInstruction ) ;
      /*  break("end doAsciiField"); */
      ^self  /* typical exit */
    endif ;
     
   endLoop ; 
}
!!

/* PRIVATE 
  Just like top level parse(), but return on finding an END tag
  (rather than an error).
*/
Def doBlockField(self | cval, tag)
{ /* break("begin doBlockField"); */
  loop while (inPos <= maxPos)
  begin 

    cval := asInt( c := inputString[inPos] ) ;

    select
      case ( (cval bitAnd AT_SPECIAL_MASK) = 0 ) /* vanilla ASCII char */ 
      is doAscii( self ) ;
      endCase
      
      case ( (tag  := (cval bitAnd AT_TAG_MASK)) = AT_INDENT_TAG )
      is doIndent( self ) ;
      endCase
      
      case ( tag = AT_BEGIN_TAG )
      is doField( self ) ;
      endCase
      
      case ( tag = AT_END_TAG )
      is
        /* break("end doBlockField"); */
       ^self ; /* let the caller deal with end-tag */
      endCase
      
      default
         displayFormattedError(ErrorTextLibClass$Inst, 
            ER_ANO_TEXT_PARSE_SPECIAL, FORCE_POPUP, nil, nil, nil);
        
    endSelect;
    
  endLoop;
}
!!

/* PUBLIC 
   Print text on window, given position & drawing context.
   Nota Bene: xPos & yPos in pixels.
   instruction is tuple( 0=type, 1=outStart, 2=inStart, 3=inEnd )
   type is #plainText or an AT_*_FIELD value
*/
Def doDisplay(self, hDC, xPos, yPos, charWidth, charHeight 
              | origTextColor, origBkColor, origBkMode, txt)
{ 
  if not( parsed?(self) )
  then parse( self ) ;
  endif ;
  
  origTextColor := Call GetSysColor(COLOR_WINDOWTEXT) ;
  origBkColor   := Call GetBkColor(   hDC ) ;
  
  /* process q1 -- color background region by drawing "colored blanks" */
  origBkMode := Call SetBkMode( hDC, OPAQUE ) ;
  do(q1,
  {using(instruction | xStart, xDelta)
    /* make string of blanks to print */
    txt := fillWith( " ", (1 + instruction[3] - instruction[2]) ) ;
    Call SetBkColor( hDC, $fieldColorDict[instruction[0]] ) ;
    Call TextOut( hDC, 
                  xPos+(instruction[1] * charWidth), 
                  yPos, 
                  txt, 
                  size(txt)
                 ) ;
  });
  
  /* process q2 -- paint colored text */
  Call SetBkMode( hDC, TRANSPARENT ) ;
  do(q2,
  {using(instruction | txt)
    txt := subString( inputString, instruction[2], (instruction[3]+1) ) ;
    Call SetTextColor( hDC, $fieldColorDict[instruction[0]] ) ;
    Call TextOut( hDC, 
                  xPos+(instruction[1] * charWidth), 
                  yPos, 
                  txt, 
                  size(txt)
                 ) ;
  });
  
  txt := nil ; /* don't save temp string */
  Call SetTextColor( hDC, origTextColor ) ;
  Call SetBkColor(   hDC, origBkColor   ) ;
  Call SetBkMode(    hDC, origBkMode    ) ;

}
!!

/* PRIVATE 

  2 cases: colored-background or colored-text

  [1] colored-text: TEXT_FIELD
   While ascii input chars, note position & move outPos.
   If find End with same field-tag, then success,
   If fine End with different field-tag, then error,
   else close off field header & take care of subfield
        when return, then extend this field again
        ...until we find our end-tag 
   Output field-text instruction to q2:
                            #(field, outPos, inStartPos, inEndPos)

   [2] colored-background: BLOCK_FIELD
    Note beginning.  Do intermediate fields. Get proper end-marker
    (else error).
    Output instruction to q1: #(field, startPos, startPos, endPos)
*/
Def doField(self | printInstruction, background?, fieldType)
{/*  break("begin doField"); */
  fieldType   := ( asInt(c) bitAnd AT_FIELD_MASK ) ;
  background? := ( fieldType in $backgroundFieldSet ) ;
  /* don't set printInstruction yet, as may have nested begins and
   * we don't want to deal with zero-length fields. 
   */ 

  /* consume Begin tag */
  inPos  := ( inPos  + 1 ) ;

  if background? /* BLOCK_FIELD */
  then
    /* push record to get queue-slot (allow nested colored regions) */
    /* N.B.: block fields are in terms of output only! */
    printInstruction := tuple( fieldType, outPos, outPos, outPos ) ;
    push( q1, printInstruction ) ;
    doBlockField( self ) ;
    select
      case (inPos > maxPos)
      is displayFormattedError(ErrorTextLibClass$Inst, 
            ER_DOFIELD_END, FORCE_POPUP, nil, nil, nil);
      endCase
      case ( ((asInt(c := inputString[inPos]) bitAnd AT_TAG_MASK) <> AT_END_TAG)
             cor ((asInt(c) bitAnd AT_FIELD_MASK) <> fieldType) )
      is displayFormattedError(ErrorTextLibClass$Inst, 
            ER_DOFIELD_END_TAG, FORCE_POPUP, nil, nil, nil);
      endCase
    endSelect;
    /* success */
    printInstruction[3] := (outPos - 1) ; /* remember end location */
    /* consume End tag */
    inPos  := ( inPos  + 1 ) ;
/*  ^self */

  else /* TEXT_FIELD case */
    doTextField( self, fieldType ) ;
    select
      case (inPos > maxPos)
      is displayFormattedError(ErrorTextLibClass$Inst, 
            ER_DOFIELD_END, FORCE_POPUP, nil, nil, nil);
      endCase
      case ( ((asInt(c := inputString[inPos]) bitAnd AT_TAG_MASK) <> AT_END_TAG)
             cor ((asInt(c) bitAnd AT_FIELD_MASK) <> fieldType) )
      is displayFormattedError(ErrorTextLibClass$Inst, 
            ER_DOFIELD_END_TAG, FORCE_POPUP, nil, nil, nil);
      endCase
    endSelect;
    /* success, consume End tag */
    inPos  := ( inPos  + 1 ) ;

  endif ;
 /*  break("end doField"); */
}
!!

/* PRIVATE 
   Just increment inPos and move output pointer.
   Don't emit printer instruction--caller handles field bounds checks.
*/
Def doIndent(self)
{ /*  break("begin doIndent"); */
  inPos  := ( inPos + 1 ) ;
  outPos := ( outPos + 
              ( (asInt(c) bitAnd AT_FIELD_MASK) * $blanksPerIndent ) 
            ) ;
/*  break("end doIndent"); */
}
!!

/* PRIVATE 
  Just like doBlockField(), but adds fieldType fields upon ASCII case.
*/
Def doTextField(self, fieldType | cval, tag)
{/*   break("begin doTextField"); */
  loop while (inPos <= maxPos)
  begin 

    cval := asInt( c := inputString[inPos] ) ;
/* break(c); */
    select
      case ( (cval bitAnd AT_SPECIAL_MASK) = 0 ) /* vanilla ASCII char */ 
      is doAsciiField( self, fieldType ) ;
      endCase
      
      case ( (tag  := (cval bitAnd AT_TAG_MASK)) = AT_INDENT_TAG )
      is doIndent( self ) ;
      endCase
      
      case ( tag = AT_BEGIN_TAG )
      is doField( self ) ;
      endCase
      
      case ( tag = AT_END_TAG )
      is 
       /* break("end doTextField"); */
        ^self ; /* let the caller deal with this */
      endCase
      
      default
        displayFormattedError(ErrorTextLibClass$Inst, 
            ER_ANO_TEXT_PARSE_SPECIAL, FORCE_POPUP, nil, nil, nil);
        
    endSelect;
    
  endLoop;
/*  break("end doTextField"); */
}
!!

/* PUBLIC 
   Treat xPos as a character position in the output string.
   Return nil or the field which corresponds to it.
*/
Def fieldIn(self, xCharPos | q2array, q2index, maxInd, result)
{
  /* Want text match, so look in q2 info */ 
  q2index := 0 ;
  q2array := asArray( q2 ) ;
  maxInd  := size( q2array ) ;
  
  if (maxInd < 1)
  then 
    ^nil ; /* no where to look! */
  endif ;

/* q2array[q2index] info format:
**     #(field, outStartPos, inStartPos, inEndPos) 
**         0         1            2          3
*/
  loop while (q2index < maxInd) 
             cand /* xCharPos in [outStart..(outStart + (inEnd - inStart))] */
             (xCharPos >= q2array[q2index][1])
             cand
             (xCharPos > (q2array[q2index][1] + 
                        (q2array[q2index][3] - q2array[q2index][2])) )
  begin 
    q2index := (q2index + 1) ;
  endLoop;
  
  if (q2index = maxInd)
  then
    q2index := (q2index - 1) ; 
  endif ;
  
  if (xCharPos < q2array[q2index][1])
  then
    ^nil ;
  endif ;

  /* return full field value */
  ^q2array[q2index]
}
!!

/* PUBLIC
   Return text for field.
*/
Def fieldStr(self, aField)
{
  if (size(q2) = 0) /* parsed text? */
  then ^nil
  endif ;

  if not(find(q2, aField)) /* field exist? & valid? */
  then ^nil
  endif ;

  ^subString( inputString, aField[2], (aField[3] + 1) )
}
!!

/* PUBLIC
   Return first text_field in q2.
*/
Def firstField(self)
{
  if (size(q2) = 0)
  then ^nil
  else ^first( q2 )
  endif;
}
!!

/* PUBLIC
   Return text for field, including markers.
*/
Def fullFieldStr(self, aField)
{
  if (size(q2) = 0) /* parsed text? */
  then ^nil
  endif ;

  if not(find(q2, aField)) /* field exist? & valid? */
  then ^nil
  endif ;

  ^subString( inputString, (aField[2] - 1), (aField[3] + 2) )
}
!!

/* PUBLIC
   Return # of hidden chars prior to xPos in inputString
*/
Def hiddenBefore(self, xPos | numHidden, index, maxInd, cVal)
{
  numHidden := index := 0 ;
  maxInd := min( size(inputString), xPos ) ;
  loop
  while (index < maxInd)
  begin 
    cVal := asInt( inputString[index] ) ;
    if ( (cVal bitAnd AT_SPECIAL_MASK) <> 0 )
    then
      numHidden := (numHidden + 1) ;
      if ((cVal bitAnd AT_TAG_MASK) = AT_INDENT_TAG)
      then  /* unexpand tabs/indents */
        numHidden := numHidden -
                     ((cVal bitAnd AT_FIELD_MASK) * $blanksPerIndent) ;
      endif ; 
    endif ;
    index := (index + 1) ;
  endLoop;
  
  ^numHidden
}
!!

/* PUBLIC -- turn hiLight on for indicated field */
Def hiLight(self, aField | outStart outEnd)
{
  hiLightOff( self ) ;  /* Safety 1st -- only 1 field on at a time */

/* Xlate from text field:  #(field, outPos, inStartPos, inEndPos)
           to block field: #(field, startPos, startPos, endPos)
*/
  outStart := aField[1] ;
  outEnd := outStart + (aField[3] - aField[2]) ; /* start + len-1 */

  add( q1, tuple( AT_SELECTED_FIELD, outStart, outStart, outEnd ) ) 
}
!!

/* PUBLIC -- is a text_field hilighted? */
Def hiLighted?(self)
{
  do(q1,
  {using(field)
    if (field[0] = AT_SELECTED_FIELD)
    then ^field
    endif;
  });

  ^nil
}
!!

/* PUBLIC -- turn hiLight on for indicated field */
Def hiLightField(self, aField)
{
  ^hiLight(self, aField) /* just an alias.. */
}!!

/* PUBLIC -- turn hiLight off */
Def hiLightOff(self | found)
{
  found := hiLighted?( self ) ;
  if found
  then remove( q1, find( q1, found ) )
  endif ;
  
  ^found
}
!!

/* PRIVATE 
   -- N.B.: Does *not* parse or print!
      If c is nil, then parsing has not taken place.
*/
Def init(self, aString)
{ 
  inputString := aString ;
  inPos := outPos := 0 ;
  maxPos := ( size(inputString) - 1 ) ;
  q1 := new( OrderedCollection, 0 ) ; /* used as Queue: push+removeFirst */
  q2 := new( OrderedCollection, 4 ) ; /* used as Queue: push+removeFirst */

}
!!

/* PUBLIC
   Return next text_field after aField.
   @@ this really should be part of OrderedCollection or Array... @@
*/
Def nextField(self, aField | index, lastIndx)
{
  if (size(q2) = 0)
  then ^nil
  endif ;

  if not(index := find(q2, aField))
  then ^nil
  endif ;

  lastIndx := find( q2, last(q2) ) ;

  if (index < lastIndx)
  then ^at( q2, (index + 1) )
  else ^nil
  endif ;
}
!!

/* Public now (for testing), PRIVATE later -- probably folded into print()
  Recursive descent => nested fields ok, overlapping fields are errors.
  Parse generates `instructions' for a print-machine.  Parsing uses 2
  queues: q1 is for colored background areas, q2 for colored text.
  See doDisplay for details of the print machine.
*/
Def parse(self | cval, tag)
{ 
  loop while (inPos <= maxPos)
  begin 

    cval := asInt( c := inputString[inPos] ) ;

    select
      case ( (cval bitAnd AT_SPECIAL_MASK) = 0 ) /* vanilla ASCII char */ 
      is doAscii( self ) ;
      endCase
      
      case ( (tag  := (cval bitAnd AT_TAG_MASK)) = AT_INDENT_TAG )
      is doIndent( self ) ;
      endCase
      
      case ( tag = AT_BEGIN_TAG )
      is doField( self ) ;
      endCase
      
      case ( tag = AT_END_TAG )
      is displayFormattedError(ErrorTextLibClass$Inst, 
            ER_ANO_TEXT_PARSE_FIELD, FORCE_POPUP, nil, nil, nil);
      endCase
      
      default
        displayFormattedError(ErrorTextLibClass$Inst, 
            ER_ANO_TEXT_PARSE_SPECIAL, FORCE_POPUP, nil, nil, nil);
        
    endSelect;
    
  endLoop;
  
}
!!

/* PUBLIC */
Def parsed?(self)
{ 
  ^c  /* if 'c' is nil, then inputString has not yet been parsed */
}
!!

/* PUBLIC
   Return next text_field after aField.
   @@ this really should be part of OrderedCollection or Array... @@
*/
Def prevField(self, aField | index, firstIndx)
{
  if (size(q2) = 0)
  then ^nil
  endif ;

  if not(index := find(q2, aField))
  then ^nil
  endif ;

  firstIndx := find( q2, first(q2) ) ;

  if (index > firstIndx)
  then ^at( q2, (index - 1) )
  else ^nil
  endif ;
}
!!

/* PUBLIC 
   Fill background of field with filled blanks.
*/
Def unHiLight(self, field, hDC, xPos, yPos, charWidth, charHeight 
              | txt)
{
    hiLightOff( self ) ;

    /* make string of blanks to print */
    txt := fillWith( " ", (1 + field[3] - field[2]) ) ;
    Call TextOut( hDC, 
                  xPos+(field[1] * charWidth), 
                  yPos, 
                  txt, 
                  size(txt)
                 ) ;
}
!!

/* PUBLIC 
   Treat xPos as a character position in the output string.
   Return the position in the input string which corresponds to it.
*/
Def whereIn(self, xPos | q2array, q2index, maxInd, result)
{
  /* Want text match, so look in q2 info */ 
  q2index := 0 ;
  q2array := asArray( q2 ) ;
  maxInd  := size( q2array ) ;
  
  if (maxInd < 1)
  then 
    ^0 ; /* no where to look! */
  endif ;

/* q2array[q2index] info format:
**     #(field, outStartPos, inStartPos, inEndPos) 
**         0         1            2          3
*/
  loop while (q2index < maxInd) 
             cand /* xPos in [outStart..(outStart + (inEnd - inStart))] */
             (xPos >= q2array[q2index][1])
             cand
             (xPos > (q2array[q2index][1] + 
                        (q2array[q2index][3] - q2array[q2index][2])) )
  begin 
    q2index := (q2index + 1) ;
  endLoop;
  
  if (q2index = maxInd)
  then
    q2index := (q2index - 1) ; 
  endif ;
  
   if (xPos < q2array[q2index][1])
  then
    ^0 ;
  endif ;

  /* inStartPos + (xPos - outStartPos) */
  result := (q2array[q2index][2] + (xPos - q2array[q2index][1])) ; 
  
  ^min( result, maxPos ) ; /* always return valid string index */
}
!!

/* ATParser Class Initialization Code */
 $blanksPerIndent    := 3 ;  /* pick what looks good */
 $backgroundFieldSet := asSet(tuple( AT_BREAK_ACT_FIELD, 
                              AT_BREAK_INACT_FIELD, 
                              AT_BREAK_HIT_FIELD, 
                              AT_CURSOR_ACT_FIELD, 
                              AT_CURSOR_INACT_FIELD,
                              AT_PC_HERE_FIELD,
                              AT_SELECTED_FIELD
                            ) );
 $fieldColorDict := new( Dictionary, 10 ) ; /*0x00bbggrr*/
 add( $fieldColorDict, AT_TYPE_NAME_FIELD,    0x00000000 /* black */  ) ;
 add( $fieldColorDict, AT_VAR_NAME_FIELD,     0x00FF01FF /* purple */ ) ;
 add( $fieldColorDict, AT_EDIT_FIELD,         0x000000FF /* red */    ) ;
 add( $fieldColorDict, AT_REFERENCE_FIELD,    0x00FF0000 /* blue */   ) ;
 add( $fieldColorDict, AT_BREAK_ACT_FIELD,    0x000000FF /* red */    ) ;
 add( $fieldColorDict, AT_BREAK_INACT_FIELD,  0x00808080 /* grey */  ) ;
 add( $fieldColorDict, AT_BREAK_HIT_FIELD,    0x000000FF /* red */   ) ;
 add( $fieldColorDict, AT_CURSOR_ACT_FIELD,   0x008F8F00 /* Lt blue */   ) ;
 add( $fieldColorDict, AT_CURSOR_INACT_FIELD, 0x00808080 /* grey */  ) ;
 add( $fieldColorDict, AT_PC_HERE_FIELD,      0x0000FFFF /* Yellow */   ) ;
 add( $fieldColorDict, AT_SELECTED_FIELD,     0x0000FFFF /* Yellow */ ) ;
 add( $fieldColorDict, #plainText,            Call GetSysColor(COLOR_WINDOWTEXT) ) ;
