RichEdit syntax coloring

Windows specific questions.
aurelVZAB
Posts: 666
Joined: Jul 02, 2008 14:55
Contact:

RichEdit syntax coloring

Post by aurelVZAB »

Is there any code written in FB which can show us simple syntax coloring with richedit control ??

thanks..
SARG
Posts: 1756
Joined: May 27, 2005 7:15
Location: FRANCE

Re: RichEdit syntax coloring

Post by SARG »

Extracted from fbdebugger this function is used to color sourcecode. Not sure it's enough simple...

h : handle of the richedit control
s : what is to be colored
c : color
d : some effects

Code: Select all

private function fb_setcolor(h As HWND,s As Integer,c As Integer,d As Integer) As Integer
'''#define WM_USER  &h0400
'''#define EM_SETCHARFORMAT 1092 'wm_user+68
''#define CFM_COLOR  &h40000000
''#define SCF_SELECTION  1
''#define SCF_WORD  2
''#define SCF_DEFAULT  0
''#define SCF_ALL  4
''#define CFE_AUTOCOLOR	1073741824
Dim lpcharformat As CHARFORMAT,selt As Integer
Select Case s
    Case 0
selt=0 'set to the default format
    Case 1
selt=SCF_ALL 'Applies the formatting to all text in the control.
    Case 2
selt=SCF_SELECTION 'Applies the formatting to the current selection.
    Case 3
selt=SCF_WORD Or SCF_SELECTION 'Applies the formatting to the selected word or words.
End Select
lpcharformat.cbsize=Len(charformat)
lpcharformat.crtextcolor=c

lpcharformat.dwmask= CFM_UNDERLINE Or CFM_BOLD Or CFM_COLOR Or CFM_ITALIC 
If d=1 Then
   lpcharformat.dweffects=CFE_AUTOCOLOR
ElseIf d=2 Then
   lpcharformat.dweffects=CFE_UNDERLINE Or CFE_BOLD 'Or STRIKEOUT'
ElseIf d=3 Then
   ' lpcharformat.dweffects=CFE_ITALIC
End If

If sendmessage(h,EM_SETCHARFORMAT,selt,Cast(LPARAM,@lpcharformat))=0 Then
	fb_message("ERROR","Set color format")
	 Return FALSE
Else
	Return TRUE
End If
End Function
aurelVZAB
Posts: 666
Joined: Jul 02, 2008 14:55
Contact:

Re: RichEdit syntax coloring

Post by aurelVZAB »

What to say ..thank you very much on that!
Ok this is for all words but how colorize specific word or few words?
jj2007
Posts: 2326
Joined: Oct 23, 2016 15:28
Location: Roma, Italia
Contact:

Re: RichEdit syntax coloring

Post by jj2007 »

Hi Aurel,

What SARG posted is permanent colouring, i.e. changing the file content - that is how RichMasm works (which has, btw, a plug-in for compiling FB sources).

In case you look for "instant" colouring, google for iczelion syntax highlighting
SARG
Posts: 1756
Joined: May 27, 2005 7:15
Location: FRANCE

Re: RichEdit syntax coloring

Post by SARG »

aurelVZAB wrote:What to say ..thank you very much on that!
Ok this is for all words but how colorize specific word or few words?
You have to select the word or any part of the text and then play with parameter 's' SCF_WORD Or SCF_SELECTION.
jj2007 wrote:*permanent colouring, i.e. changing the file content
What do you mean ?
aurelVZAB
Posts: 666
Joined: Jul 02, 2008 14:55
Contact:

Re: RichEdit syntax coloring

Post by aurelVZAB »

Hi jj
yes i need both from loading file and instant using EN_CHANGE event
by the way i found one but is in PureBasic ...you may look into that forum...
it work fine even i am not ssure that i understand how complete code work due to
little bit crazy syntax of purebasic but all SendMessage apis are same ...
jj2007
Posts: 2326
Joined: Oct 23, 2016 15:28
Location: Roma, Italia
Contact:

Re: RichEdit syntax coloring

Post by jj2007 »

SARG wrote:
jj2007 wrote:*permanent colouring, i.e. changing the file content
What do you mean ?
Your code uses the permanent formatting functions of the RichEdit control; Iczelion's version changes the way it is drawn, based on syntax rules.

For your inspiration: TinyIDE for FreeBasic (permanent formatting that gets saved with the file; scroll down to see the BATCH$)
D.J.Peters
Posts: 8586
Joined: May 28, 2005 3:28
Contact:

Re: RichEdit syntax coloring

Post by D.J.Peters »

setting the font and color for a text range is simple:

Code: Select all

if Preproc.Find(Key)       then
                SetCharFormat(hCtrl,@cfPreproc)
              elseif Datatype.Find(Key)  then
                SetCharFormat(hCtrl,@cfDatatype)
              elseif Language.Find(Key)  then
                SetCharFormat(hCtrl,@cfLanguage)
              elseif Runtime.Find(Key)   then
                SetCharFormat(hCtrl,@cfRuntime)
              elseif Assembler.Find(Key) then
                SetCharFormat(hCtrl,@cfAssembler)
              else
                ' unknow ident
                SetCharFormat(hCtrl,@cfDefault)
              end if
The hardest part is to find out what are comments, numbers, preprocessor, keywords, strings etc.
and is currently a single or multiline comment active is an string parsing active ...

Code: Select all

' colorize a buffer
sub SYNTAX_T.ColorizeBuffer(hCtrl   as HWND, _
                            pBuf    as ubyte ptr, _
                            iChars  as integer, _
                            iOffset as integer)
  static as integer MComment=0
  dim as integer InString,InHex,InNumber,InIdent,SComment
  dim as integer iStart,iEnd,i
  dim as single  p1
  dim as integer op
  dim as HWND hWin

  if iChars>4096 then
    hWin = GetParent(hCtrl)
    p1=iChars/10
  end if

  while (pBuf[i]<>0)
    ' is multi line comment are active ?
    if (MComment=0) then
      MComment = ((pBuf[i]=asc("/")) AndAlso (pBuf[i+1]=asc("'")))
    end if
    ' start of single line comment
    if (SComment=0) AndAlso (MComment=0) AndAlso (InString=0) then SComment = (pBuf[i]=asc("'"))
    ' any comment active ?
    if (MComment<>0) or (SComment<>0) then
      SendMessage(hCtrl,EM_SETSEL,iOffset+i,iOffset+i+1)
      SetCharformat(hCtrl,@cfComment)
      if (MComment<>0) then
        ' end of multi line comment 
        if ((pBuf[i]=asc("/")) andalso (pBuf[i-1]=asc("'"))) then
          MComment=0:SComment=0
        end if
      end if
      ' end of single line comment ?
      if (SComment<>0) AndAlso (pBuf[i]=13) then SComment=0
    else
      ' "
      if (InString=0) AndAlso (pBuf[i]=34) then
        InString=1:iStart=i:iEnd=i
      end if
      if InString then
        ' end of string 
        if (i>iStart) andalso (pBuf[i]=34) then
          InString=0
          SendMessage(hCtrl,EM_SETSEL,iOffset+iStart,iOffset+iEnd+1)
          SetCharformat(hCtrl,@cfString)
        else
          iEnd+=1
        end if
      else
        ' no multi or single line comment and no string
        if (InNumber=0) AndAlso (InHex=0) AndAlso (InIdent=0) then
          ' must not be preproc e.g. print #1,...
          if (pBuf[i]=asc("#")) AndAlso (IsNumber(pBuf[i+1])=0) AndAlso (IsDelimiter(pBuf[i+1])=0) then 
            InIdent=1:iStart=i:iEnd=i
          elseif (chr(pBuf[i])="&") AndAlso (lcase(chr(pBuf[i+1]))="h") then
            InHex=i+2:iStart=i:iEnd=i+1
          elseif IsNumber(pBuf[i]) then
            InNumber=1:iStart=i:iEnd=i
          else 
            InIdent = (IsDelimiter(pBuf[i])=0) 
            if InIdent then iStart=i:iEnd=i
          end if
        end if
        
        if InHex then
          ' end of hex ?
          if (i>iStart) then InHex=IsHex(pBuf[i+1])
          if (InHex=0) then
            SendMessage(hCtrl,EM_SETSEL,iOffset+iStart,iOffset+iEnd+1)
            SetCharformat(hCtrl,@cfNumber)
          else
            iEnd+=1
          endif
        elseif InNumber then
          ' end of number ?
          InNumber=IsNumber(pBuf[i+1])
          if InNumber=0 then
            SendMessage(hCtrl,EM_SETSEL,iOffset+iStart,iOffset+iEnd+1)
            SetCharformat(hCtrl,@cfNumber)
          else
            iEnd+=1
          endif
        elseif (InIdent<>0) then
          ' end of ident ?
          if IsDelimiter(pBuf[i+1]) then
            dim as string Ident
            SendMessage(hCtrl,EM_SETSEL,iOffset+iStart,iOffset+iEnd+1)
            for p as integer = iStart to iEnd
              Ident &= lcase(chr(pBuf[p]))
            next
            if Ident<>"rem" then
              ' what is it ?
              dim as uinteger Key=crc32(strptr(Ident),len(Ident))
              if Preproc.Find(Key)       then
                SetCharFormat(hCtrl,@cfPreproc)
              elseif Datatype.Find(Key)  then
                SetCharFormat(hCtrl,@cfDatatype)
              elseif Language.Find(Key)  then
                SetCharFormat(hCtrl,@cfLanguage)
              elseif Runtime.Find(Key)   then
                SetCharFormat(hCtrl,@cfRuntime)
              elseif Assembler.Find(Key) then
                SetCharFormat(hCtrl,@cfAssembler)
              else
                ' unknow ident
                SetCharFormat(hCtrl,@cfDefault)
              end if
              InIdent = 0
            else
              ' 'rem' single line comment
              SComment = 1
              InIdent  = 0
              i-=3
            end if
          else
            iEnd+=1
          end if
        else
          ' must be an delimiter
          SendMessage(hCtrl,EM_SETSEL,iOffset+i,iOffset+i+1)
          SetCharFormat(hCtrl,@cfDelimiter)
        end if
      end if
    end if
    i+=1
    
    ' large file parsing active ?
    if (hWin<>NULL) then
      dim as integer p = int(i/p1)
      if p<>op then
        dim as string msg = "File parsing " & string(p,"|")
        SendMessage(hWin,WM_SETTEXT,0,cast(LPARAM,strptr(msg)))
        op=p
      end if
    end if
  wend
  
  ' file pasrsing active
  if (hWin<>NULL) then
    dim as string msg = "Syntax colorize with CRC32()"
    SendMessage(hWin,WM_SETTEXT,0,cast(LPARAM,strptr(msg)))
  end if

end sub
Don't worry about the slow loading the complete file are colourized !

Normally you colourize onyl the visible part of the RichEdit control or if you edit a single line !

Joshy

You MUST save this file as "ide.bas" it will syntax highlighting it self :-)

Code: Select all

#define WIN_INCLUDEALL
#include "windows.bi"
#include "win/commctrl.bi"
#include "win/richedit.bi"

' missing in "richedit.bi" usefull for CHARFORMAT2
#ifndef CFM_WEIGHT
 #define CFM_WEIGHT &H00400000
#endif

'#define DEBUG ' !!!

#ifdef DEBUG
 #define DPRINT(msg) OPEN CONS FOR OUTPUT AS #99: PRINT #99,msg:CLOSE #99 :
 #define WPRINT(msg) DPRINT("warning: " & msg)
 #define EPRINT(msg) OPEN ERR FOR OUTPUT AS #99: PRINT #99,"error: " & msg:CLOSE #99 :beep:sleep:end 1 :
#else
 #define DPRINT(msg) :
 #define WPRINT(msg) :
 #define EPRINT(msg) :
#endif

#define RGB24(r,g,b) (b shl 16) or (g shl 8) or (r)

#define CLR_PLAIN     RGB24( 32, 32, 32)
#define CLR_PAPER     RGB24(255,255,255)
#define CLR_STRING    RGB24(192,  0,  0)
#define CLR_COMMENT   RGB24( 32,128, 32)
#define CLR_PREPROC   RGB24(192,128, 32)
#define CLR_NUMBER    RGB24(  0,168,168)
#define CLR_LANGUAGE  RGB24( 32, 32,196)
#define CLR_DATATYPE  RGB24(  0,  0,216)
#define CLR_RUNTIME   RGB24(  0,  0,196)
#define CLR_ASSEMBLER RGB24(128,  0,128)
#define CLR_DELIMITER RGB24(128,128,128)

rem single line comment
' single line comment

/' 
  multiline 
  line
  comment
'/

type KEYWORDTABLE_T
  declare constructor
  declare destructor
  declare sub       Add(Key as ulong)
  declare function  Find(Key as ulong) as boolean
  private:
  as ulong ptr   Keys
end type
constructor KEYWORDTABLE_T
  dprint("KEYWORDTABLE_T()")
  Keys = callocate(sizeof(ulong))
end constructor

destructor KEYWORDTABLE_T
  if (Keys<>NULL) then deallocate Keys
  dprint("KEYWORDTABLE_T~")
end destructor

sub KEYWORDTABLE_T.Add(Key as ulong)
  ' don't add it again
  if find(Key) then return
  Keys[0]+=1
  Keys = reallocate(Keys,(Keys[0]+1)*sizeof(ulong))
  Keys[Keys[0]]=Key
end sub

function KEYWORDTABLE_T.Find(Key as ulong) as boolean
  if Keys[0]<1 then return false
  for i as integer=1 to Keys[0]
    if Keys[i]=Key then return true
  next
  return false
end function

type SYNTAX_T
  declare constructor
  declare destructor
  declare sub Colorize(hCtrl as HWND,iStart as integer, iEnd as integer)

  private:
  declare function CRC32(pBuffer     as any Ptr, _
                         nBufferSize as integer) as ulong
  declare sub      AddKeywords(table as KEYWORDTABLE_T, _
                               KeyWords() as string)
  declare sub      InitKeywords
  declare sub      AddPreproc
  declare sub      AddDatatype
  declare sub      AddLanguage
  declare sub      AddRuntime
  declare sub      AddAssembler

  declare sub      ColorizeBuffer(hCtrl   as HWND, _
                                  pBuf    as ubyte ptr, _
                                  nChars  as integer, _
                                  nOffset as integer)

  declare function IsWhite    (char as ubyte) as boolean
  declare function IsNumber   (char as ubyte) as boolean
  declare function IsHex      (char as ubyte) as boolean
  declare function IsDelimiter(char as ubyte) as boolean
  declare function IsOperator (char as ubyte) as boolean
  declare sub      SetCharFormat(hCtrl as HWND, _
                                 pcf   as CHARFORMAT ptr)

  const as integer S_FLAG = SCF_SELECTION

  as CHARFORMAT cfDefault
  as CHARFORMAT cfComment
  as CHARFORMAT cfString
  as CHARFORMAT cfNumber
  as CHARFORMAT cfDelimiter

  as CHARFORMAT cfPreproc
  as CHARFORMAT cfDatatype
  as CHARFORMAT cfLanguage
  as CHARFORMAT cfRuntime
  as CHARFORMAT cfAssembler

  as KEYWORDTABLE_T Preproc
  as KEYWORDTABLE_T Datatype
  as KEYWORDTABLE_T Language
  as KEYWORDTABLE_T Runtime
  as KEYWORDTABLE_T Assembler
end type
dim shared as SYNTAX_T ptr Syntax

constructor SYNTAX_T
  dprint("SYNTAX_T()")
  with cfDefault
  .cbSize          = sizeof(CHARFORMAT)
  .dwMask          = CFM_CHARSET or _
                     CFM_FACE    or _
                     CFM_SIZE    or _
                     CFM_OFFSET  or _
                     CFM_COLOR
  .dwEffects       = 0
  .yHeight         = 12 * 20 ' pts * 20 twips/point = n twips
  .bCharSet        = ANSI_CHARSET
  .bPitchAndFamily = FIXED_PITCH or FF_MODERN
  .yOffset         = 0
  .szFaceName      = "Courier New"
  end with
  cfComment   = cfDefault
  cfString    = cfDefault
  cfNumber    = cfDefault
  cfDelimiter = cfDefault

  cfPreproc   = cfDefault
  cfDatatype  = cfDefault
  cfLanguage  = cfDefault
  cfRuntime   = cfDefault
  cfAssembler = cfDefault

  cfDefault.crTextColor   = CLR_PLAIN
  cfComment.crTextColor   = CLR_COMMENT
  cfString.crTextColor    = CLR_STRING
  cfNumber.crTextColor    = CLR_NUMBER
  cfDelimiter.crTextColor = CLR_DELIMITER

  cfPreproc.crTextColor   = CLR_PREPROC
  cfDatatype.crTextColor  = CLR_DATATYPE
  cfLanguage.crTextColor  = CLR_LANGUAGE
  cfRuntime.crTextColor   = CLR_RUNTIME
  cfAssembler.crTextColor = CLR_ASSEMBLER

  InitKeywords()

end constructor

destructor SYNTAX_T
  dprint("SYNTAX_T~")
end destructor

' create a unic 32 bit id from any buffer or string
function SYNTAX_T.CRC32(byval pBuffer   As any Ptr, _
                        byval nBufferSize As Integer) As ULong
  Static Table(255) As ULong => { _
  &H00000000, &H77073096, &HEE0E612C, &H990951BA, _
  &H076DC419, &H706AF48F, &HE963A535, &H9E6495A3, _
  &H0EDB8832, &H79DCB8A4, &HE0D5E91E, &H97D2D988, _
  &H09B64C2B, &H7EB17CBD, &HE7B82D07, &H90BF1D91, _
  &H1DB71064, &H6AB020F2, &HF3B97148, &H84BE41DE, _
  &H1ADAD47D, &H6DDDE4EB, &HF4D4B551, &H83D385C7, _
  &H136C9856, &H646BA8C0, &HFD62F97A, &H8A65C9EC, _
  &H14015C4F, &H63066CD9, &HFA0F3D63, &H8D080DF5, _
  &H3B6E20C8, &H4C69105E, &HD56041E4, &HA2677172, _
  &H3C03E4D1, &H4B04D447, &HD20D85FD, &HA50AB56B, _
  &H35B5A8FA, &H42B2986C, &HDBBBC9D6, &HACBCF940, _
  &H32D86CE3, &H45DF5C75, &HDCD60DCF, &HABD13D59, _
  &H26D930AC, &H51DE003A, &HC8D75180, &HBFD06116, _
  &H21B4F4B5, &H56B3C423, &HCFBA9599, &HB8BDA50F, _
  &H2802B89E, &H5F058808, &HC60CD9B2, &HB10BE924, _
  &H2F6F7C87, &H58684C11, &HC1611DAB, &HB6662D3D, _
  &H76DC4190, &H01DB7106, &H98D220BC, &HEFD5102A, _
  &H71B18589, &H06B6B51F, &H9FBFE4A5, &HE8B8D433, _
  &H7807C9A2, &H0F00F934, &H9609A88E, &HE10E9818, _
  &H7F6A0DBB, &H086D3D2D, &H91646C97, &HE6635C01, _
  &H6B6B51F4, &H1C6C6162, &H856530D8, &HF262004E, _
  &H6C0695ED, &H1B01A57B, &H8208F4C1, &HF50FC457, _
  &H65B0D9C6, &H12B7E950, &H8BBEB8EA, &HFCB9887C, _
  &H62DD1DDF, &H15DA2D49, &H8CD37CF3, &HFBD44C65, _
  &H4DB26158, &H3AB551CE, &HA3BC0074, &HD4BB30E2, _
  &H4ADFA541, &H3DD895D7, &HA4D1C46D, &HD3D6F4FB, _
  &H4369E96A, &H346ED9FC, &HAD678846, &HDA60B8D0, _
  &H44042D73, &H33031DE5, &HAA0A4C5F, &HDD0D7CC9, _
  &H5005713C, &H270241AA, &HBE0B1010, &HC90C2086, _
  &H5768B525, &H206F85B3, &HB966D409, &HCE61E49F, _
  &H5EDEF90E, &H29D9C998, &HB0D09822, &HC7D7A8B4, _
  &H59B33D17, &H2EB40D81, &HB7BD5C3B, &HC0BA6CAD, _
  &HEDB88320, &H9ABFB3B6, &H03B6E20C, &H74B1D29A, _
  &HEAD54739, &H9DD277AF, &H04DB2615, &H73DC1683, _
  &HE3630B12, &H94643B84, &H0D6D6A3E, &H7A6A5AA8, _
  &HE40ECF0B, &H9309FF9D, &H0A00AE27, &H7D079EB1, _
  &HF00F9344, &H8708A3D2, &H1E01F268, &H6906C2FE, _
  &HF762575D, &H806567CB, &H196C3671, &H6E6B06E7, _
  &HFED41B76, &H89D32BE0, &H10DA7A5A, &H67DD4ACC, _
  &HF9B9DF6F, &H8EBEEFF9, &H17B7BE43, &H60B08ED5, _
  &HD6D6A3E8, &HA1D1937E, &H38D8C2C4, &H4FDFF252, _
  &HD1BB67F1, &HA6BC5767, &H3FB506DD, &H48B2364B, _
  &HD80D2BDA, &HAF0A1B4C, &H36034AF6, &H41047A60, _
  &HDF60EFC3, &HA867DF55, &H316E8EEF, &H4669BE79, _
  &HCB61B38C, &HBC66831A, &H256FD2A0, &H5268E236, _
  &HCC0C7795, &HBB0B4703, &H220216B9, &H5505262F, _
  &HC5BA3BBE, &HB2BD0B28, &H2BB45A92, &H5CB36A04, _
  &HC2D7FFA7, &HB5D0CF31, &H2CD99E8B, &H5BDEAE1D, _
  &H9B64C2B0, &HEC63F226, &H756AA39C, &H026D930A, _
  &H9C0906A9, &HEB0E363F, &H72076785, &H05005713, _
  &H95BF4A82, &HE2B87A14, &H7BB12BAE, &H0CB61B38, _
  &H92D28E9B, &HE5D5BE0D, &H7CDCEFB7, &H0BDBDF21, _
  &H86D3D2D4, &HF1D4E242, &H68DDB3F8, &H1FDA836E, _
  &H81BE16CD, &HF6B9265B, &H6FB077E1, &H18B74777, _
  &H88085AE6, &HFF0F6A70, &H66063BCA, &H11010B5C, _
  &H8F659EFF, &HF862AE69, &H616BFFD3, &H166CCF45, _
  &HA00AE278, &HD70DD2EE, &H4E048354, &H3903B3C2, _
  &HA7672661, &HD06016F7, &H4969474D, &H3E6E77DB, _
  &HAED16A4A, &HD9D65ADC, &H40DF0B66, &H37D83BF0, _
  &HA9BCAE53, &HDEBB9EC5, &H47B2CF7F, &H30B5FFE9, _
  &HBDBDF21C, &HCABAC28A, &H53B39330, &H24B4A3A6, _
  &HBAD03605, &HCDD70693, &H54DE5729, &H23D967BF, _
  &HB3667A2E, &HC4614AB8, &H5D681B02, &H2A6F2B94, _
  &HB40BBE37, &HC30C8EA1, &H5A05DF1B, &H2D02EF8D }
  
  if (pBuffer=0) orelse (nBufferSize<1) then return 0
  dim as ubyte ptr p = pBuffer
  dim as ubyte ptr e = p + nBufferSize
  dim as ulong crc = &HFFFFFFFF
  while (p<e)
    crc = Table((crc xor *p) and &HFF) xor (crc shr 8)
    p+=1
  wend 
  return crc xor &HFFFFFFFF

if 0 then ' not used it's only to colorize inline assembler
  dim as ulong ptr t=@Table(0)
  asm
    mov edi,[pBuffer]
    mov esi,[t]
    mov ecx,[nBufferSize]
    mov eax,&HFFFFFFFF
    mov edx,&HFF
    push ebp
    mov ebp,edx
    xor edx,edx
    loop_it:
      mov dl,[edi]
      mov ebx,eax
      xor eax,edx
      and eax,ebp
      shr ebx,8
      mov eax,[esi+eax*4]
      inc edi
      xor eax,ebx
    dec ecx
    jnz loop_it
    pop ebp
    xor eax,&HFFFFFFFF
    mov [function],eax
  end asm
end if  

end function

' add some groups of keywords
sub SYNTAX_T.InitKeywords
  AddPreproc()
  AddDatatype()
  AddLanguage()
  AddRuntime()
  AddAssembler()
end sub
' create a crc32 ulong table from array with keywords
sub SYNTAX_T.AddKeywords(table as KEYWORDTABLE_T,KeyWords() as string)
  dim as integer nKeys = ubound(KeyWords)+1
  for i as integer = 0 to nKeys-1
    dim as integer nChars = len(KeyWords(i))
    if nChars>0 then table.Add(crc32(strptr(KeyWords(i)),nChars))
  next
end sub
' can be replaced with keyword file loading
sub SYNTAX_T.AddPreproc
  dim as string keywords(...) = { _
  "#define","defined", _
  "#else","#elseif","#endif","#endmacro","#error", _
  "#if","#ifdef","#ifndef","#include","#inclib", _
  "#lang","#libpath","#line", _
  "#macro", _
  "#pragma","#print", _
  "#undef", _
  "__fb_debug__", _
  "__fb_lang__", _
  "__fb_version__", _
  "__fb_win32__", _
  "__fb_linux__", _
  "__fb_dos__" }
  AddKeywords(Preproc,KeyWords())
end sub
' can be replaced with keyword file loading
sub SYNTAX_T.AddDatatype
  dim as string keywords(...) = { _
  "any",_
  "byte",_
  "double",_
  "integer",_
  "long","longint",_
  "ptr",_
  "short","single","string",_
  "ubyte","ushort","uinteger",_
  "var",_
  "wstring",_
  "zstring"}
  AddKeywords(Datatype,KeyWords())
end sub
' can be replaced with keyword file loading
sub SYNTAX_T.AddLanguage
  dim as string keywords(...) = { _
  "as","and","andalso","asm", _
  "case","cast","cint","cdbl","class","const","constructor","cptr", _
  "data","declare","delete","destructor","dim","do", _
  "else","end","enum","export", _
  "function","for", _
  "goto","gosub", _
  "if","iif","int", _
  "new","not", _
  "operator","or", _
  "private","public", _
  "read","restore","return", _
  "select","sizeof","static","sub", _
  "then","type", _
  "wend","while","with", _
  "xor" }
  AddKeywords(Language,KeyWords())
end sub
' can be replaced with keyword file loading
sub SYNTAX_T.AddRuntime
  dim as string keywords(...) = { _
  "abs","access","acos","allocate","alpha","atan2","atn", _
  "bin","binary", _
  "chr","close","cls","cons","cos","condbroadcast","condcreate","conddestroy","condwait", _
  "deallocate","dir", _
  "get","getmouse", _
  "err","exp", _
  "fix","frac", _
  "hex", _
  "input","int","imagecreate","imagedestroy","imageinfo", _
  "lcase","left","len","line","locate","log","lpt", _
  "mid","mod","mutexcreate","mutexdestroy","mutexlock","mutexunlock" , _
  "oct","open","output", _
  "pipe","pmap","pset","print","put", _
  "randomize","reallocate","rgb","rgba","right","rnd", _
  "scrn","screen","screeninfo","screenres","sin","sgn","sqr","str","strptr", _
  "tan","threadcreate","threadwait", _
  "ucase", _
  "val","varptr","view", _
  "wbin","wchr","width","whex","woct","write","wstr", _
  "window"}
  AddKeywords(Runtime,KeyWords())
end sub
' can be replaced with keyword file loading
sub SYNTAX_T.AddAssembler
  dim as string keywords(...) = { _
  "ah","al","ax", _
  "bh","bl","bx", _
  "call","ch","cl","cx", _
  "cmova","cmovae","cmovb","cmovbe","cmovc", _
  "cmove","cmovg","cmovge","cmovl","cmovle", _
  "cmovna","cmovnae","cmovnb","cmovnbe", _
  "cmovnc","cmovne","cmovng","cmovnge","cmovnl", _
  "cmovnle","cmovno","cmovnp","cmovns","cmovnz", _
  "cmovo","cmovp","cmovpe","cmovpo","cmovs","cmovz", _
  "dec","dh","dl","dx", _
  "eax","ebp","ebx","ecx","edx","edi","esi","esp", _
  "inc", _
  "ja","jae","jb","jbe","jc","jcxz","je","jecxz", _
  "jg","jge","jl","jle","jmp","jna", _
  "jnae","jnb","jnbe","jnc","jne","jng","jnge","jnl", _
  "jnle","jno","jnp","jns","jnz", _
  "jo","jp","jpe","jpo","js","jz", _
  "loop","loope","loopne","loopnz","loopz", _
  "mm0","mm1","mm2","mm3","mm4","mm5","mm6","mm7", _
  "mov", _
  "pop","push", _
  "seta","setae","setb","setbe","setc","sete", _
  "setg","setge","setl","setle","setna","setnae", _
  "setnb","setnbe","setnc","setne","setng","setnge", _
  "setnl","setnle","setno","setnp","setns","setnz", _
  "seto","setp","setpe","setpo","sets","setz", _
  "st0","st1","st2","st3","st4","st5","st6","st7", _
  "xmm0","xmm1","xmm2","xmm3","xmm4","xmm5","xmm6","xmm7"}
  AddKeywords(Assembler,KeyWords())
end sub

' is current char a white char
function SYNTAX_T.IsWhite(c as ubyte) as boolean
  return ((c=9) or (c=32) or (c=10) or (c=13))
end function
' is current char a number char
function SYNTAX_T.IsNumber(c as ubyte) as boolean
  return ((c>=asc("0")) AndAlso (c<=asc("9")))
end function
' is current char a hex char
function SYNTAX_T.IsHex(c as ubyte) as boolean
  if IsNumber(c) then return true
  select case lcase(chr(c))
  case "a" to "f" : return true
  case else : return false
  end select  
end function
' is current char an operator
function SYNTAX_T.IsOperator(c as ubyte) as boolean
  select case chr(c)
  case "=","<",">","*","/","\","-","+","&","@":return true
  case else : return false
  end select
end function
' is the char a delimiter
function SYNTAX_T.IsDelimiter(c as ubyte) as boolean
  if IsWhite(c) then return true
  if IsOperator(c)  then return true
  select case chr(c)
  case "(",")","[","]",",",".",":":return true
  case else : return false
  end select
end function

' set font,size,style,color to the curent selection
sub SYNTAX_T.SetCharFormat(hCtrl as HWND,pcf as CHARFORMAT ptr)
  SendMessage(hCtrl,EM_SETCHARFORMAT,S_FLAG,cast(LPARAM,pcf))
end sub

' colorize a range of chars
sub SYNTAX_T.Colorize(hCtrl as HWND, iStart as integer, iEnd as integer)
  dim as integer nChars
  if iStart=iEnd then return

  if (iStart = 0) AndAlso (iEnd = -1) then
    nChars = SendMessage(hCtrl,WM_GETTEXTLENGTH,0,0)
    SendMessage(hCtrl,EM_SETSEL,0,nChars)
  else
    nChars = iEnd - iStart
    SendMessage(hCtrl,EM_SETSEL,iStart,iEnd)
  end if
  
  dim as ubyte ptr pBuf = new ubyte[nChars+1]
  pBuf[nChars] = 0
  dim as integer nRet = SendMessage(hCtrl,EM_GETSELTEXT,0,cast(LPARAM,pBuf))
  SetCharFormat(hCtrl,@cfDefault)
  ColorizeBuffer(hCtrl,pBuf,nRet,iStart)
  delete pBuf
end sub

' colorize a '0' terminated buffer
sub SYNTAX_T.ColorizeBuffer(hCtrl   as HWND, _
                            pBuf    as ubyte ptr, _
                            iChars  as integer, _
                            iOffset as integer)
  static as boolean bMultiLineComment=false
  
  dim as boolean bString,bHex,bNumber,bIdent,bSingleLineComment
  dim as integer iStart,iEnd,i
  dim as single  p1
  dim as integer op
  dim as HWND hWin

  if iChars>4096 then
    hWin = GetParent(hCtrl)
    p1 = iChars/10
  end if

  while (pBuf[i]<>0)
    ' is multi line "/'" comment ?
    if (bMultiLineComment=false) then
      bMultiLineComment = ((pBuf[i]=asc("/")) AndAlso (pBuf[i+1]=asc("'")))
    end if
    
    ' single "'" line comment ?
    if (bSingleLineComment=false) AndAlso (bMultiLineComment=false) AndAlso (bString=false) then
      bSingleLineComment = (pBuf[i]=asc("'"))
    end if
    
    ' any comment active ?
    if (bMultiLineComment=true) or (bSingleLineComment=true) then
      SendMessage(hCtrl,EM_SETSEL,iOffset+i,iOffset+i+1)
      SetCharformat(hCtrl,@cfComment)
      if (bMultiLineComment=true) then
        ' end of multi line "'/" comment ? 
        if ((pBuf[i]=asc("/")) andalso (pBuf[i-1]=asc("'"))) then
          bMultiLineComment=false : bSingleLineComment=false
        end if
      end if
      ' end of single line comment ?
      if (bSingleLineComment=true) AndAlso (pBuf[i]=13) then
        bSingleLineComment=false
      end if
      
    else ' if we are here no comment are active
      
      ' is it a '"' string ?
      if (bString=false) AndAlso (pBuf[i]=34) then
        bString=true : iStart=i : iEnd=i ' start of selection range 
      end if
      if (bString=true) then
        ' end of string 
        if (i>iStart) andalso (pBuf[i]=34) then
          bString=false
          SendMessage(hCtrl,EM_SETSEL,iOffset+iStart,iOffset+iEnd+1)
          SetCharformat(hCtrl,@cfString)
        else
          iEnd+=1 ' increase selection range
        end if
      else
        ' if we are here there are no multi or single line comment and no string active
        
        ' no number no hex no ident
        if (bNumber=false) AndAlso (bHex=false) AndAlso (bIdent=false) then
          ' must not be preproc e.g. print #1,... close #hFile
          if cbool(pBuf[i]=asc("#")) AndAlso (IsNumber(pBuf[i+1])=false) AndAlso (IsDelimiter(pBuf[i+1])=false) then 
            bIdent=true : iStart=i : iEnd=i ' start of selection range
            ' is "&H" hex = ?
          elseif (chr(pBuf[i])="&") AndAlso (lcase(chr(pBuf[i+1]))="h") then
            bHex=true : iStart=i : iEnd=i + 1  ' start of selection range + "h"
            ' is number ?
          elseif IsNumber(pBuf[i]) then
            bNumber=true : iStart=i : iEnd=i ' start of selection range
            ' is not a delimiter it nust be an ident !
          elseif (IsDelimiter(pBuf[i])=false) then
            bIdent=true : iStart=i : iEnd=i ' start of selection range
          end if
          
        end if
        
        if (bHex=true) then
          ' end of hex ?
          if (i>iStart) then bHex=IsHex(pBuf[i+1])
          if (bHex=false) then
            SendMessage(hCtrl,EM_SETSEL,iOffset+iStart,iOffset+iEnd+1)
            SetCharformat(hCtrl,@cfNumber)
          else
            iEnd+=1 ' increase selection range
          endif
        
        elseif (bNumber=true) then
          ' end of number ?
          if (IsNumber(pBuf[i+1])=false) then
            bNumber=false
            SendMessage(hCtrl,EM_SETSEL,iOffset+iStart,iOffset+iEnd+1)
            SetCharformat(hCtrl,@cfNumber)
          else
            iEnd+=1 ' increase selection range
          endif
        
        elseif (bIdent=true) then
          ' end of ident ?
          if (IsDelimiter(pBuf[i+1])=true) then
            dim as string Ident
            SendMessage(hCtrl,EM_SETSEL,iOffset+iStart,iOffset+iEnd+1)
            for p as integer = iStart to iEnd
              Ident &= lcase(chr(pBuf[p]))
            next
            
            ' not the "old" comment ident
            if Ident<>"rem" then
              ' what is it ?
              dim as ulong Key=crc32(strptr(Ident),len(Ident))
              if Preproc.Find(Key)       then
                SetCharFormat(hCtrl,@cfPreproc)
              elseif Datatype.Find(Key)  then
                SetCharFormat(hCtrl,@cfDatatype)
              elseif Language.Find(Key)  then
                SetCharFormat(hCtrl,@cfLanguage)
              elseif Runtime.Find(Key)   then
                SetCharFormat(hCtrl,@cfRuntime)
              elseif Assembler.Find(Key) then
                SetCharFormat(hCtrl,@cfAssembler)
              else
                ' unknow ident
                SetCharFormat(hCtrl,@cfDefault)
              end if
              bIdent = false
            else
              ' it's 'rem' single line comment
              bSingleLineComment = true
              bIdent = false
              i-=3
            end if
          else
            iEnd+=1 ' increase selection range
          end if
          
        else
          ' must be an delimiter
          SendMessage(hCtrl,EM_SETSEL,iOffset+i,iOffset+i+1)
          SetCharFormat(hCtrl,@cfDelimiter)
        end if
      end if
    end if
    
    i+=1 ' next char pos in buffer
    
    ' large file parsing active ?
    if (hWin<>NULL) then
      dim as integer p = int(i/p1)
      if p<>op then
        dim as string msg = "File parsing " & string(p,"|")
        SendMessage(hWin,WM_SETTEXT,0,cast(LPARAM,strptr(msg)))
        op=p
      end if
    end if
  wend
  
  ' file pasrsing active
  if (hWin<>NULL) then
    dim as string msg = "Syntax colorize with CRC32()"
    SendMessage(hWin,WM_SETTEXT,0,cast(LPARAM,strptr(msg)))
  end if

end sub

const IDC_RICHEDIT = 1000

enum MENU_IDS
  IDM_NEW = 1100
  IDM_OPEN
  IDM_SAVE
  IDM_SAVE_AS
  IDM_QUIT
  IDM_UNDO
  IDM_COPY
  IDM_PASTE
  IDM_CUT
  IDM_SEARCH
  IDM_NEXT
  IDM_REPLACE
  IDM_COMPILE
  IDM_RUN
  IDM_EXECUTE
  IDM_HELP
  IDM_ABOUT
end enum

type MENU_T
  public:
  declare constructor(hParent as HWND)
  declare destructor
  declare function AddMenu     (Title as string,_
                                flag  as integer=0) as HMENU
  declare function BeginSubMenu(Title as string,_
                                flag  as integer=0) as HMENU
  declare sub      EndSubMenu  (oldMenu as HMENU)
  declare function AddItem     (Text as string, _
                                ID   as integer,_
                                flag as integer=0) as HMENU
  declare function AddAccelItem(Text as string, _
                                ID   as integer, _
                                vMod as integer, _
                                vKey as integer, _
                                flag as integer=0) as HMENU
  declare function AddAltItem  (Text as string, _
                                ID   as integer,_ 
                                vKey as integer,_
                                flag as integer=0) as HMENU
  declare function AddCtrlItem (Text as string, _
                                ID   as integer,_
                                vKey as integer,_
                                flag as integer=0) as HMENU
  declare function AddShiftItem(Text as string,_
                                ID   as integer,_
                                vKey as integer,_
                                flag as integer=0) as HMENU
  declare function AddKeyItem  (Text as string,_
                                ID   as integer,_
                                vKey as integer,_
                                flag as integer=0) as HMENU
  declare function Separator as HMENU
  declare function Finalize    (hParent as HWND) as integer

  as HACCEL hAccel

  private:
  declare function VKeyToText(vKey as integer) as string
  as HWND    hParent
  as HMENU   hMenuBar
  as HMENU   curMenu
  as integer nAccels
  as LPACCEL pAccels
end type

constructor MENU_T(hParent as HWND)
  dprint("MENU_T()")
  hMenuBar = CreateMenu()
  AddMenu     "&File"
  AddCtrlItem "&New"        ,IDM_NEW    ,VK_N ,MF_GRAYED
  Separator
  AddCtrlItem "&Open ..."   ,IDM_OPEN   ,VK_O ,MF_GRAYED
  Separator
  AddCtrlItem "&Save"       ,IDM_SAVE   ,VK_S ,MF_GRAYED
  AddItem     "Save &as ...",IDM_SAVE_AS      ,MF_GRAYED
  Separator
  AddCtrlItem "&Quit"       ,IDM_QUIT   ,VK_Q

  AddMenu     "&Edit"
  AddCtrlItem "Undo"        ,IDM_UNDO   ,VK_Z ,MF_GRAYED
  Separator
  AddCtrlItem "Copy"        ,IDM_COPY   ,VK_C ,MF_GRAYED
  AddCtrlItem "Paste"       ,IDM_PASTE  ,VK_V ,MF_GRAYED
  Separator
  AddCtrlItem "Cut"         ,IDM_CUT    ,VK_X ,MF_GRAYED

  AddMenu     "Search"
  AddCtrlItem "Find"        ,IDM_SEARCH ,VK_F ,MF_GRAYED
  AddKeyItem  "Find next"   ,IDM_NEXT   ,VK_F3,MF_GRAYED
  AddCtrlItem "Replace"     ,IDM_REPLACE,VK_H ,MF_GRAYED

  AddMenu     "Build"
  AddKeyItem  "Compile"     ,IDM_COMPILE,VK_F5,MF_GRAYED
  AddKeyItem  "Run"         ,IDM_RUN    ,VK_F6,MF_GRAYED
  AddKeyItem  "Build & Run" ,IDM_EXECUTE,VK_F7,MF_GRAYED

  AddMenu     "Help"
  AddKeyItem  "Context Help",IDM_HELP   ,VK_F1,MF_GRAYED
  AddItem     "About ..."   ,IDM_ABOUT        ,MF_GRAYED
  Finalize(hParent)
end constructor

destructor MENU_T
  if (hAccel  <>NULL) then DestroyAcceleratorTable(hAccel)
  if (pAccels <>NULL) then deallocate pAccels
  if (hMenuBar<>NULL) then DestroyMenu(hMenuBar)
  dprint("MENU_T~")
end destructor

function MENU_T.VKeyToText(vKey as integer) as string
  select case vKey
  ' VK_0 ... VK_9
  case &H30 to &H39: return chr(vKey)
  ' VK_A ... VK_Z
  case &H41 to &H5A: return chr(vKey)
  ' VK_F1 ...VK_FVK_F24
  case &H70 to &H87: return "F" & trim(str(vKey-&H6F))
  end select
end function

function MENU_T.AddMenu(Title as string,_
                        flag  as integer) as HMENU
  curMenu = CreatePopupMenu()
  AppendMenu(hMenuBar, _
             MF_STRING Or MF_POPUP or flag, _
             cast(UINT_PTR ,curMenu), Title)
  return curMenu
end function

function MENU_T.BeginSubMenu(Title as string,_
                             flag as integer) as HMENU
  function  = curMenu
  dim as HMENU subMenu = CreatePopupMenu()
  AppendMenu(curMenu, _
             MF_STRING Or MF_POPUP or flag, _
             cast(UINT_PTR ,subMenu), Title)
  curMenu = subMenu
end function

sub MENU_T.EndSubMenu(oldMenu as HMENU)
  curMenu = oldMenu
end sub

function MENU_T.AddItem(Text as string, _
                        ID   as integer,_
                        flag as integer) as HMENU
  AppendMenu(curMenu,MF_STRING or flag,ID,Text)
  return curMenu
end function

function MENU_T.AddAccelItem(Text as string, _
                             ID   as integer, _
                             vMod as integer, _
                             vKey as integer,_
                             flag as integer) as HMENU
  select case vMod
    case FALT     : Text &= !"\tAlt + "
    case FCONTROL : Text &= !"\tCtrl + "
    case FSHIFT   : Text &= !"\tShift + "
    case else     : Text &= !"\t"
  end select
  Text &= VKeyToText(vKey)
  AppendMenu(curMenu,MF_STRING or flag,ID,Text)

  nAccels+=1
  pAccels = reallocate(pAccels,sizeof(ACCEL)*nAccels)
  pAccels[nAccels-1].fVirt = FNOINVERT or FVIRTKEY or vMod
  pAccels[nAccels-1].Key   = vKey
  pAccels[nAccels-1].Cmd   = ID

  return curMenu
end function

function MENU_T.AddAltItem(Text as string, _
                           ID   as integer, _
                           vKey as integer,_
                           flag as integer) as HMENU
  return AddAccelItem(Text,ID,FALT,vKey,flag)
end function

function MENU_T.AddCtrlItem(Text as string, _
                            ID   as integer,_
                            vKey as integer,_
                            flag as integer) as HMENU
  return AddAccelItem(Text,ID,FCONTROL,vKey, flag)
end function

function MENU_T.AddShiftItem(Text as string, _
                             ID   as integer, _
                             vKey as integer,_
                             flag as integer) as HMENU
  return AddAccelItem(Text,ID,FSHIFT,vKey,flag)
end function

function MENU_T.AddKeyItem(Text as string, _
                           ID   as integer, _
                           vKey as integer,_
                           flag as integer) as HMENU
  return AddAccelItem(Text,ID,0,vKey,flag)
end function

function MENU_T.Separator as HMENU
  AppendMenu(curMenu,MF_SEPARATOR,0,NULL)
  return curMenu
end function

function MENU_T.Finalize(hParent as HWND) as integer
  if nAccels>0 then
   hAccel = CreateAcceleratorTable(pAccels,nAccels)
  end if
  function = SetMenu(hParent,hMenuBar)
  DrawMenuBar hParent
end function

type FORM_T
  declare constructor (sTitle  as string = "", _
                       iLeft   as integer = CW_USEDEFAULT, _
                       iTop    as integer = CW_USEDEFAULT, _
                       iWidth  as integer = CW_USEDEFAULT, _
                       iHeight as integer = CW_USEDEFAULT)
  declare destructor

  declare static function FormProc(hWnd   as HWND  , _ 
                                   uMsg   as UINT  , _ 
                                   wParam as WPARAM, _ 
                                   lParam as LPARAM ) as LRESULT
  as HINSTANCE hInstance
  as HWND      hForm
  as string    WindowClass
end type

constructor FORM_T(sTitle  as string, _
                   iLeft   as integer, _
                   iTop    as integer, _
                   iWidth  as integer, _
                   iHeight as integer)
  static as integer ID = 0
  dprint("FORM_T()")
  ID+=1
  WindowClass = "FORM" & ID
  hInstance   = GetModuleHandle(NULL)
  dim as WNDCLASSEX wcex
  with wcex
  .cbSize        = sizeof(WNDCLASSEX)
  .style         = CS_VREDRAW or CS_HREDRAW or CS_DBLCLKS
  .lpfnWndProc   = @FormProc
  .cbClsExtra    = 0
  .cbWndExtra    = 0
  .hInstance     = hInstance
  .hIcon         = LoadIcon(NULL, IDI_APPLICATION)
  .hCursor       = LoadCursor(0, IDC_ARROW)
  .hbrBackground = cast(HBRUSH,COLOR_BTNFACE + 1)
  .lpszMenuName  = NULL
  .lpszClassName = strptr(WindowClass)
  .hIconSm       = LoadIcon(NULL, IDI_APPLICATION)
  end with
  RegisterClassEx(@wcex)

  if sTitle="" then sTitle=WindowClass
  hForm = CreateWindowEx(WS_EX_CONTROLPARENT or _
                         WS_EX_WINDOWEDGE    or _
                         WS_EX_LEFT          or _
                         WS_EX_LTRREADING, _
                         WindowClass, _
                         sTitle, _
                         WS_OVERLAPPEDWINDOW or WS_VISIBLE, _
                         iLeft, iTop, iWidth, iHeight, _
                         0   , _ ' no parent
                         NULL, _
                         hInstance, _
                         cast(any ptr,@this))
end constructor

destructor FORM_T
  dprint("FORM~")
end destructor

function FORM_T.FormProc(hWin   as HWND, _ 
                         uMsg   as UINT, _ 
                         wParam as WPARAM, _ 
                         lParam as LPARAM ) as LRESULT
  static as integer nCreates =0
  select case uMsg
  case WM_GETMINMAXINFO
    ' lpmmi = caast(LPMINMAXINFO,lParam)
  case WM_NCCREATE
    ' lpcs = cast(LPCREATESTRUCT,lParam)
  case WM_NCCALCSIZE
    ' fCalcValidRects = wParam
    ' TRUE  lpncsp = cast(LPNCCALCSIZE_PARAMS,lParam)
    ' FALSE lpncsp = cast(LPRECT,lParam)
  case WM_CREATE ' after WM_NCCREATE
    #ifndef __FB_64BIT__
    SetWindowLong(hWin,GWL_USERDATA,*cptr(integer ptr,lParam) )
    #else
    SetWindowLongPtr(hWin, GWLP_USERDATA, lParam)
    #endif
    nCreates+=1
  case WM_SHOWWINDOW
    ' fShow    = wParam
    ' fnStatus = cast(integer,lParam)
  case WM_WINDOWPOSCHANGING
    ' lpwp = cast(LPWINDOWPOS,lParam)
  case WM_ACTIVATEAPP
    'fActive    = wParam
    'dwThreadID = cast(DWORD,lParam)
  case WM_NCACTIVATE
    'fActive = wParam
  case WM_GETICON
    ' fType = wParam
    ' ICON_BIG or ICON_SMALL 
  case WM_ACTIVATE 
    ' fActive      = LOWORD(wParam)
    ' fMinimized   = HIWORD(wParam)
    ' hwndPrevious = cast(HWND,lParam)
  case WM_SETFOCUS 
    'hwndLoseFocus = cast(HWND,wParam)
  case WM_NCPAINT
    'hdc = GetDCEx(hwnd, cast(HRGN,wParam, DCX_WINDOW or DCX_INTERSECTRGN)
    ' Paint into this DC
    'ReleaseDC(hwnd, hdc)
  case WM_ERASEBKGND 
    ' hdc = cast(HDC,wParam)
  case WM_SIZE
    dim as HWND hCtrl = GetDlgItem(hWin,IDC_RICHEDIT)
    if (hCtrl<>NULL) then
      ' fwSizeType = wParam
      dim as integer nWidth  = LOWORD(lParam)-20
      dim as integer nHeight = HIWORD(lParam)-20
      MoveWindow(hCtrl,10,10,nWidth,nHeight,1)
    end if

  case WM_MOVE 
    ' xClientPos = LOWORD(lParam)
    ' yClientPos = HIWORD(lParam) 

  case WM_CLOSE
    
  case WM_DESTROY
    nCreates-=1
    if nCreates<1 then PostQuitMessage(0):return 0
  case WM_NCDESTROY

  case WM_NCHITTEST 'position of cursor 
    ' xPos = LOWORD(lParam)
    ' yPos = HIWORD(lParam)
  case WM_SETCURSOR
    ' hwnd = cast(HWND,wParam)
    ' nHittest = LOWORD(lParam)
    ' MouseMsg = HIWORD(lParam)
  case WM_COMMAND
    dim as integer wNotifyCode = HIWORD(wParam)
    dim as integer wID         = LOWORD(wParam)
    select case wNotifyCode
    case 0
      select case wID
      case IDM_NEW     : dprint("IDM_NEW")
      case IDM_OPEN    : dprint("IDM_OPEN")
      case IDM_SAVE    : dprint("IDM_SAVE")
      case IDM_SAVE_AS : dprint("IDM_SAVE_AS")
      case IDM_QUIT    : dprint("IDM_QUIT")
      SendMessage(hWin,WM_CLOSE,wParam,lParam)
      case IDM_UNDO
      case IDM_COPY    : dprint("IDM_COPY")
      case IDM_PASTE   : dprint("IDM_PASTE")
      case IDM_CUT     : dprint("IDM_CUT")
      case IDM_SEARCH  : dprint("IDM_SEARCH")
      case IDM_NEXT    : dprint("IDM_NEXT")
      case IDM_REPLACE : dprint("IDM_REPLACE")
      case IDM_HELP    : dprint("IDM_CONTEXT")
      case IDM_ABOUT   : dprint("IDM_ABOUT")
      end select
    case 1
      ' redirect accel's as 'normal' menu message
      SendMessage(hWin,WM_COMMAND,wID,lParam)
    case else
      if wID = IDC_RICHEDIT then
        dim as HWND hCtrl= cast(HWND,lParam)
        dim as integer LineIndex
        dim as integer CharIndex
        dim as integer LineLength
        select case wNotifyCode
        case EN_SETFOCUS  : dprint("IDC_RICHEDIT EN_SETFOCUS")
        case EN_KILLFOCUS : dprint("IDC_RICHEDIT EN_KILLFOCUS")
        case EN_CHANGE
        if (Syntax<>NULL) then
          CharIndex  = SendMessage(hCtrl,EM_LINEINDEX,  -1,0)
          LineLength = SendMessage(hCtrl,EM_LINELENGTH, -1,0)
          dim as CHARRANGE cr
          SendMessage(hCtrl,EM_EXGETSEL,0,cast(uinteger,@cr))
          Syntax->Colorize(hCtrl,CharIndex,CharIndex + LineLength)
          SendMessage(hCtrl,EM_EXSETSEL,0,cast(uinteger,@cr))
        end if
        case EN_UPDATE    : dprint("IDC_RICHEDIT EN_UPDATE")
        case else         : dprint("IDC_RICHEDIT " & wNotifyCode)
        end select
      else
        dprint("WM_COMMAND " & wID & "," & wNotifyCode)
      end if
    end select
    
  case WM_SYSCOMMAND
    dim as integer uCmdType = (wParam and &HFFF0)
    select case uCmdType
    case SC_CLOSE
      dprint("hWin WM_SYSCOMMAND SC_CLOSE")
      SendMessage(hWin,WM_CLOSE,wParam,lParam)
    end select
  end select
  return DefWindowProc(hWin, uMsg, wParam, lParam)
end function

type EDIT_T
  declare constructor(hParent as HWND)
  declare destructor
  declare function GetLineCount as integer
  declare function GetLine(row as integer) as string
  declare function Load(FileName as string) as integer
  as HWND hEdit
  private:
  #ifndef __FB_64BIT__
  declare static function ReadStreamCallback(dwUser as DWORD , _
                                             pBuf   as LPBYTE, _
                                             nBytes as LONG  ,  _
                                             pReaded as LONG ptr) as DWORD
  #else
  declare static function ReadStreamCallback(dwUser as DWORD_PTR , _
                                             pBuf   as LPBYTE, _
                                             nBytes as LONG  ,  _
                                             pReaded as LONG ptr) as DWORD
  #endif                                             
end type

constructor EDIT_T(hParent as HWND)
  dprint("EDIT_T()")
  dim as RECT rec
  GetClientRect(hParent,@rec)
  dim as integer w = rec.right-rec.left
  dim as integer h = rec.bottom-rec.top
  dim as string EditClass

  ' first try V2.0
  dim as HMODULE hLib = LoadLibrary("RICHED20.Dll") 
  if (hLib<>NULL) then 
    EditClass ="RICHEDIT20A" 
    dprint("RichEdit control V2.0")
  else
    ' fall back V1.0
    hLib = LoadLibrary("RICHED32.Dll")
    If (hLib<>NULL) then
       EditClass ="RICHEDIT" 
       dprint("RichEdit control V1.0 with 64K limit !")
    else
      EPRINT("InitControls() can't load RichEdit <= V2.0 !")
    end if
  end if

  hEdit = CreateWindowEx(WS_EX_CLIENTEDGE or _
                         WS_EX_LEFT       or _
                         WS_EX_LTRREADING or _
                         WS_EX_RIGHTSCROLLBAR, _
                         EditClass, _
                         "file not loaded ...", _
                         WS_CHILD       or _
                         WS_VISIBLE     or _
                         WS_HSCROLL     or _
                         WS_VSCROLL     or _
                         WS_TABSTOP     or _
                         ES_LEFT        or _
                         ES_MULTILINE   or _
                         ES_AUTOHSCROLL or _
                         ES_AUTOVSCROLL or _
                         ES_WANTRETURN, _
                         10,10,w-20,h-20, _
                         hParent, _
                         cast(HMENU,IDC_RICHEDIT), _
                         GetModuleHandle(0), _
                         NULL)
  ' no 64K Limit on V2.0
  SendMessage(hEdit,EM_LIMITTEXT,-1,0)
#if 0
  dim as CHARFORMAT cf
  with cf
  .cbSize          = sizeof(CHARFORMAT)
  .dwMask          = CFM_CHARSET or _
                     CFM_FACE    or _
                     CFM_SIZE    or _
                     CFM_OFFSET  or _
                     CFM_COLOR
  .dwEffects       = 0
  .yHeight         = 10 * 20  '  pts * 20 twips/point = n twips
  .bCharSet        = ANSI_CHARSET
  .bPitchAndFamily = FIXED_PITCH or FF_MODERN
  .yOffset         = 0
  .szFaceName      = "Courier New"
  .crTextColor     = &HCC0000
  end with
  SendMessage(hEdit, EM_SETCHARFORMAT,SCF_ALL, cast(LPARAM,@cf))
#endif
  SendMessage(hEdit, EM_SETBKGNDCOLOR,FALSE  , cast(LPARAM,CLR_PAPER)) 
end constructor

destructor EDIT_T
  DPRINT("EDIT_T~")
end destructor

function EDIT_T.GetLineCount as integer
  return SendMessage(hEdit,EM_GETLINECOUNT,0,0)
end function

function EDIT_T.GetLine(row as integer) as string
  if row<0               then return ""
  if row>=GetLineCount() then return ""
  dim as string ret
  dim as ubyte ptr pTmp = allocate(4096) 
  *cptr(ushort ptr,ptmp) = 4096

  dim as integer nChars = SendMessage(hEdit,EM_GETLINE,row,cast(LPARAM,pTmp))
  if nChars>0 then
     ret = space(nChars)
     for i as integer=0 to nChars-1
       ret[i]=ptmp[i]
     next
  end if
  function = ret
  deallocate ptmp
end function
#ifndef __FB_64BIT__
function EDIT_T.ReadStreamCallback(dwUser as DWORD , _
                                   pBuf   as LPBYTE, _
                                   nBytes as LONG  ,  _
                                   pReaded as LONG ptr) as DWORD
#else                                   
function EDIT_T.ReadStreamCallback(dwUser as DWORD_PTR, _
                                   pBuf   as LPBYTE, _
                                   nBytes as LONG  ,  _
                                   pReaded as LONG ptr) as DWORD

#endif
  dim as integer size
  get #dwUser,,*pBuf,nBytes,size
  
  *pReaded=size
  return 0
end function


function EDIT_T.Load(FileName as string) as integer
  dim as EDITSTREAM es
  dim as integer hFile = FreeFile()
  if 0=open(FileName,for binary access read,as #hFile) then
    with es
    .dwCookie    = hFile
    .pfnCallback = @ReadStreamCallback
    end with
    SendMessage(hEdit, EM_STREAMIN, SF_TEXT, cast(LPARAM,@es))
    close #hFile
    return 1
  end if
  return 0
end function

type APPLICATION_T
  declare constructor
  declare destructor
  declare function run as integer
  as FORM_T ptr form
  as MENU_T ptr menu
  as EDIT_T ptr edit
end type

constructor APPLICATION_T
  DPRINT("APPLICATION_T()")
  dim as INITCOMMONCONTROLSEX IccEx
  with IccEx
  .dwSize = sizeof(INITCOMMONCONTROLSEX)
  .dwICC  = ICC_WIN95_CLASSES      or _ ' &H000000FF
            ICC_DATE_CLASSES       or _ ' &H00000100
            ICC_USEREX_CLASSES     or _ ' &H00000200
            ICC_COOL_CLASSES       or _ ' &H00000400
            ICC_INTERNET_CLASSES   or _ ' &H00000800
            ICC_PAGESCROLLER_CLASS or _ ' &H00001000
            ICC_NATIVEFNTCTL_CLASS or _ ' &H00002000
            ICC_STANDARD_CLASSES   or _ ' &H00004000
            ICC_LINK_CLASS              ' &H00008000
  end with
  InitCommonControlsEx @IccEx
  syntax = new SYNTAX_T
  form   = new FORM_T(command(0),100,100,640,480)
  menu   = new MENU_T(form->hForm)
  edit   = new EDIT_T(form->hForm)

  chdir ExePath

  ' diable redrawing
  ' SendMessage(edit->hEdit,WM_SETREDRAW,false,0)
  ' set hourglas
  dim as HANDLE oldCursor = SetCursor(LoadCursor(NULL, IDC_WAIT))
  ' disable change events
  SendMessage(edit->hEdit,EM_SETEVENTMASK,0,ENM_NONE)
  ' load source code and colorize it
  if edit->Load("ide.bas") then
    syntax->Colorize(edit->hEdit,0,-1)
  end if
  ' enable change events
  SendMessage(edit->hEdit,EM_SETEVENTMASK,0,ENM_CHANGE)
  ' set old mouse icon
  SetCursor(oldCursor)
  ' enable redrawing
  ' SendMessage(edit->hEdit,WM_SETREDRAW,true,0)
  ' trigger client redraw
  ' RedrawWindow(edit->hEdit,NULL,NULL,RDW_INVALIDATE or RDW_UPDATENOW or RDW_ERASE)

end constructor

destructor APPLICATION_T
  if edit   then delete edit
  if menu   then delete menu
  if form   then delete form
  if syntax then delete syntax
  DPRINT("APPLICATION_T~")
end destructor

function APPLICATION_T.Run as integer

  DPRINT("APPLICATION_T.Run")
  dim as MSG msg
  dim as integer blnIgnore
  while GetMessage(@msg, NULL, 0, 0)
    if (msg.hwnd<>NULL) then
      if (Menu<>NULL) AndAlso (Menu->hAccel<>NULL) then
        blnIgnore=TranslateAccelerator(msg.hwnd, _
                                       Menu->hAccel,_
                                       @msg)
      end if
    end if
    if (blnIgnore=0) then
      TranslateMessage(@msg)
      DispatchMessage(@msg)
    end if
  wend
  return msg.wParam
end function

' 
' start your engine :-)
'
function main as integer
  dim as APPLICATION_T app
  return app.run
end function

end main()
Last edited by D.J.Peters on Sep 08, 2020 1:46, edited 3 times in total.
jj2007
Posts: 2326
Joined: Oct 23, 2016 15:28
Location: Roma, Italia
Contact:

Re: RichEdit syntax coloring

Post by jj2007 »

undefined reference to `BufferSize'

If I comment out line 266, ' mov ecx,[BufferSize], it compiles and I see a window saying "file not loaded". I don't understand the joke...
D.J.Peters
Posts: 8586
Joined: May 28, 2005 3:28
Contact:

Re: RichEdit syntax coloring

Post by D.J.Peters »

jj2007 wrote:I don't understand the joke...
BufferSize must be nBufferSize

Get the source code again the inline assembler code are not used it's only to colorize it !

The demo comes from a time where FreeBASIC was only 32-bit but I fixed that should work now !

I tested both 32 and 64 bit
fbc ide.bas -w pendantic -asm intel

Joshy
Image
aurelVZAB
Posts: 666
Joined: Jul 02, 2008 14:55
Contact:

Re: RichEdit syntax coloring

Post by aurelVZAB »

WOW
thanks Joshy
it works great just take few secons for parsing ..
it is complex program i don't get that assembly at all...shame on me ...
Also may i ask why subs are UDT ?
is that "must be " for this program or not?
and only one Sendmessage others are inside functions if i inderstand it
ufff i really need time with this program ....
SARG
Posts: 1756
Joined: May 27, 2005 7:15
Location: FRANCE

Re: RichEdit syntax coloring

Post by SARG »

@aurelVZAB
Sorry I didn't fully understand your request. In fbdebugger I did also syntax coloring but it's too slow for biggest source codes.

@jj2007
Now that's clearer ;-)

@D.J.Peters
Maybe I would use your code. Do you agree ?
jj2007
Posts: 2326
Joined: Oct 23, 2016 15:28
Location: Roma, Italia
Contact:

Re: RichEdit syntax coloring

Post by jj2007 »

Joshy,
It works now: the file loads when I start the exe from the source's folder. Compliments, well done!
D.J.Peters
Posts: 8586
Joined: May 28, 2005 3:28
Contact:

Re: RichEdit syntax coloring

Post by D.J.Peters »

@aurelVZAB the inline assembler stuf isn't needed at all you can delete it "if 0 then bla bla" will never executed :-)

This isn't a real editor it was only a test for the richedit control I wrote many years ago.
I never code windows only stuff !

Why not using FLTK-c for your project ?
(it will run on Windows and Linux 32/64 bit)

Joshy
D.J.Peters
Posts: 8586
Joined: May 28, 2005 3:28
Contact:

Re: RichEdit syntax coloring

Post by D.J.Peters »

again for all here :-)

You can remove the inline assembler stuff
if you delete it "fbc ide.bas" will work :-)

Joshy
Post Reply