'******************************************************************************
'* 
'* COLOR GRAPHIC ADAPTER (CGA) v.1.0 (VIDEO DEVICE)
'*
'* Introduced in early x86 PC, PC/XT
'*
'* Supported platform/bus: X86
'* 
'* Version history:
'*  2007,2008 - initial emulation (by WadiM)
'*
'* Configurable device parameters:
'* - MemoryAddress as dword - video memory base address 
'* - MemoryRange as dword - video memory address range
'* - MemorySizeKB as dword - video memory size in KB
'*
'****************************************************************************** 

//DEBUG.ON 'uncomment to enable debug messages (can be slow for hi-freq events)

'ISA device interface support
public use object DEVICE_ISA

//device name
DeviceName="CGA Video Adapter"
DeviceGroupName="CGA"
DebugName="VID_CGA" 

//Device params (can be accessed externally)
dim PARAM_MEMADDR as dword=0xB8000                      'base memory address
    DEVPARAMS.Add(PARAM_MEMADDR,"MEMORYADDRESS")
    DEVPARAMS.Required=true : DEVPARAMS.Configured=true
dim PARAM_MEMRANGE as dword=0x8000                      'memory space size
    DEVPARAMS.Add(PARAM_MEMRANGE,"MEMORYRANGE")
    DEVPARAMS.Required=true : DEVPARAMS.Configured=true
dim PARAM_MEMSIZEKB as dword=16                         'memory buffer size, kb
    DEVPARAMS.Add(PARAM_MEMSIZEKB,"MEMORYSIZEKB")
    DEVPARAMS.Required=true : DEVPARAMS.Configured=true

//Current video mode params (with values for mode 3 = TEXT 80x25x16 as example)
dim VideoMode as word=3 'detected index of current mode
dim IsGraphMode as boolean=false 'is current mode is graph mode (non-text)
dim ColCount as byte=80, RowCount as byte=25 'count of columns and rows of chars
dim ColSize as byte=2 'size of one charplace (in bytes - symbol, attribute,...)
dim RowSize as byte=ColSize*ColCount 'size of one charline (in bytes)
dim CharWidth as byte=8, CharHeight as byte=8 'size of char in pixels
dim Width as word=320, Height as word=200 'width and height of screen in pixels
dim PixelSize as byte=4 'size of pixel in bits (i.e. bpp of color)
dim LineSize as word 'size of horizontal scanline in bytes
dim Aspect as single=320/200 'aspect ratio of current screen
dim BlinkFlag as boolean 'h/w cursor blinking flag (true - invisible)
dim Changed as boolean=true 'screen was changed

//Video memory buffer
use object MEMORY_BUFFER as vidmem 
    vidmem.Size=PARAM_MEMSIZEKB*1024
    vidmem.BaseAddress=PARAM_MEMADDR 
    vidmem.AddressRange=PARAM_MEMRANGE
    vidmem.AddressMask=vidmem.Size-1
    vidmem.AddressOffset=0

//Pixel decoder (used to render graphic modes and to store current palette)
use object PIXEL_DECODER as pix

//Video bitmap (used to render video memory on it)
use object BITMAP_IMAGE as image

//Chargen (used to render chars in text modes, non-changable in standard CGA)
//Can be used externally to upload other fonts or to access from main memory
public use object MEMORY_BUFFER as CharGen : CharGen.Size=8*256
CharGen.Bytes(0)=ArrayFile("Fonts\ru8x8.fnt",0,256*8) 'default font
    CharGen.BaseAddress=PARAM_MEMADDR   'can be used instead of videobuffer
    CharGen.AddressRange=PARAM_MEMRANGE 'by some ex-CGA clones
    CharGen.AddressMask=0x7FF
    CharGen.AddressOffset=0

//CGA port values
dim CRT_INDEX as byte 'crt index port (3D4h)
dim CRT_DATA(0x12) as byte 'crt data ports (3D5h)
dim MODE_VALUE as byte 'mode port value (3D8h)
dim COLOR_VALUE as byte 'color port value (3D9h)
dim STATE_VALUE as byte 'state port value (3DAh)

//CGA palette (used to program video memory palette)
dim CGAPalette(16) as dword 	
    CGAPalette(0x0)=RGB(0,0,0) 		'black 
    CGAPalette(0x1)=RGB(0,0,168) 	'blue
    CGAPalette(0x2)=RGB(0,168,0) 	'green
    CGAPalette(0x3)=RGB(0,168,168) 	'cyan
    CGAPalette(0x4)=RGB(168,0,0) 	'red
    CGAPalette(0x5)=RGB(168,0,168) 	'magenta
    CGAPalette(0x6)=RGB(168,84,0) 	'brown
    CGAPalette(0x7)=RGB(168,168,168) 	'gray
    CGAPalette(0x8)=RGB(84,84,84) 	'dark gray
    CGAPalette(0x9)=RGB(84,84,252) 	'light blue
    CGAPalette(0xA)=RGB(84,252,84) 	'light green
    CGAPalette(0xB)=RGB(84,252,252) 	'light cyan
    CGAPalette(0xC)=RGB(252,84,84) 	'light red
    CGAPalette(0xD)=RGB(252,84,252) 	'light magenta
    CGAPalette(0xE)=RGB(252,252,84) 	'yellow
    CGAPalette(0xF)=RGB(252,252,252) 	'white

'------------------------------- Tools ----------------------------------------

//Update screen (video memory) palette by port values
procedure UpdatePalette 
 dim i as integer, intens as byte
 intens=8 'hmm, most emulators use dark colors, but I worked on XT/clones 
          'with bright colors (and CGA games look bad with dark colors, imho :)
 select case VideoMode
  case 0 to 3 //CGA text modes
        for i=0 to 15 'whole palette
        pix.Palette(i)=CGAPalette(i) : next
  case 4 to 5 //CGA low-res graph modes
        pix.Palette(0)=CGAPalette(COLOR_VALUE and 0xF) //bgcolor
        //other 3 colors
        select case true
         case (COLOR_VALUE and 0x4)<>0 //zero palette
           pix.Palette(1)=CGAPalette(3+intens) 'light cyan
           pix.Palette(2)=CGAPalette(4+intens) 'light red
           pix.Palette(3)=CGAPalette(7+intens) 'white
         case (COLOR_VALUE and 0x20)=0 //first palette
           pix.Palette(1)=CGAPalette(2+intens) 'light green
           pix.Palette(2)=CGAPalette(4+intens) 'light red
           pix.Palette(3)=CGAPalette(6+intens) 'yellow
         case else //second palette
           pix.Palette(1)=CGAPalette(3+intens) 'light cyan
           pix.Palette(2)=CGAPalette(5+intens) 'light magenta
           pix.Palette(3)=CGAPalette(7+intens) 'white
         end select
  case 6 //CGA high-res mode
         pix.Palette(0)=CGAPalette(0) //black
         pix.Palette(1)=CGAPalette(15) //white
 end select
end

'-------------------------------- H/W Interface -------------------------------

//Write video memory
public function WriteMemory alias vidmem.WriteMemory

//Read video memory
public function ReadMemory alias vidmem.ReadMemory

//Write crt index port
public property CRT_INDEX_PORT(Value as byte)
 ?? DebugPrefix;">CRT_Index_Port=";Hex(Value,2);"h"
 CRT_INDEX=Value
end

//Read crt index port
public function CRT_INDEX_PORT as byte
 result=CRT_INDEX
 ?? DebugPrefix;"<CRT_Index_Port=";Hex(result,2);"h"
end

//Write crt data port
public property CRT_DATA_PORT(Value as byte)
 ?? DebugPrefix;">CRT_Data_Port=";Hex(Value,2);"h"
 if CRT_INDEX<0x12 then : CRT_DATA(CRT_INDEX)=Value : Changed=true : end if
end

//Read crt data port
public function CRT_DATA_PORT as byte
 if CRT_INDEX<0x12 then result=CRT_DATA(CRT_INDEX) else result=0xFF
 ?? DebugPrefix;"<CRT_Data_Port=";Hex(result,2);"h"
end

//Write mode port
public property MODE_PORT(Value as byte)
 ?? DebugPrefix;">Mode_Port=";Hex(Value,2);"h"
 MODE_VALUE=Value /*vidmem.ResetVideo*/ : Changed=true 
 //Detection of current video mode params
 IsGraphMode=(MODE_VALUE and 2)<>0 'graph mode flag
 if not(IsGraphMode) then //TEXT MODES
    //resolution flag
    if (MODE_VALUE and 1)=0 then //low-res
       ColCount=40 : VideoMode=0 //40x25x16
    else //high-res
       ColCount=80 : VideoMode=2 //80x25x16
    end
    //color mode flag
    if (MODE_VALUE and 4)=0 then VideoMode=VideoMode+1
    //set or calculate other mode params
    RowCount=25 : CharWidth=8 : CharHeight=8
    Width=ColCount*CharWidth : Height=RowCount*CharHeight
    ColSize=2 : RowSize=ColCount*ColSize
    PixelSize=4 : LineSize=0
 else //GRAPH MODES
    //resolution flag
    if (MODE_VALUE and 0x10)=0 then //low-res
       ColCount=40 : VideoMode=4 : PixelSize=2 //320x200x4
    if (MODE_VALUE and 4)=0 then VideoMode=VideoMode+1 //color mode flag
    else //high-res
       ColCount=80 : VideoMode=6 : PixelSize=1 //640x200x2
    end
    RowCount=25 : CharWidth=8 : CharHeight=8
    Width=ColCount*CharWidth : Height=RowCount*CharHeight
    ColSize=CharWidth*PixelSize/8 'bytes (rare used, no need to use "shr" :)
    RowSize=((CharWidth*ColCount)*PixelSize)/8 'bytes
    LineSize=(Width*PixelSize)/8 'bytes
    pix.changed=true 'to update pixel info
 end if
 UpdatePalette 'update current palette by new settings
end

//Read mode port
public function MODE_PORT as byte
 result=0xFF //non-readable on standard CGA (i.e. 0xFF),
 ?? DebugPrefix;"<Mode_Port=";Hex(result,2);"h"
end

//Write color port
public property COLOR_PORT(Value as byte)
 ?? DebugPrefix;">Color_Port=";Hex(Value,2);"h"
 COLOR_VALUE=Value : Changed=true 
 UpdatePalette 'update current palette by new settings
end

//Read color port
public function COLOR_PORT as byte
 result=0xFF //non-readable on standard CGA (i.e. 0xFF),
 ?? DebugPrefix;"<Color_Port=";Hex(result,2);"h"
end

//Read state port (fake timings - but fast and workable at least) 
//Exact timings implementation can be slow with current scipts performance,
//because in CGA text modes apps can actively check state port to avoid "snow"
//and it can cause slowdowns almost to freezing degree (because very hi-freq)
dim HRetraceCounter as byte=0 //retrace counter for fake timings
public function STATE_PORT as byte
 //calculate current part of screen frame
 dim ftime as double=frac(pc.EmuTime)*50
 dim perc as integer=frac(ftime)*100
 //vertical sync flag if less then 1/2 of frame
 if perc<50 then  //vsync flag
    STATE_VALUE=STATE_VALUE or 8 
    else : STATE_VALUE=STATE_VALUE and (not 8) : end
 //pure stub of scanline retraces
 if (HRetraceCounter and 4)=0 then : STATE_VALUE=STATE_VALUE or 1
    else : STATE_VALUE=STATE_VALUE and (not 1) : end if
 HRetraceCounter=HRetraceCounter+1
 result=STATE_VALUE
 ?? DebugPrefix;"<State_Port=";Hex(result,2);"h"
end

//Write lightpen reset port
public property PEN_RESET_PORT(Value as byte)
 ?? DebugPrefix;">Pen_Reset_Port=";Hex(Value,2);"h"
 //Changed=true 
 //TODO
end

//Write lightpen set port
public property PEN_SET_PORT(Value as byte)
 ?? DebugPrefix;">Pen_Set_Port=";Hex(Value,2);"h"
 //Changed=true 
 //TODO
end

'------------------------------ Rendering -------------------------------------

//Cursor parameters
dim CurLn1 as byte, CurLn2 as byte, CurOffs as word

//Check cursor visibility
function IsCursorVisible as boolean
 result=false : if VideoMode>3 then exit 'only in text modes
 dim pos as integer, w as word
 pos=CRT_DATA(0xD) or shl(CRT_DATA(0xC),8) 'hardware-scroll offset
 CurLn1=CRT_DATA(0xA) and 0x1F 'top line (char-related)
 CurLn2=CRT_DATA(0xB) and 0x1F 'bottom line in (char-related)
 if (CurLn1>=CharHeight) or (CurLn1>CurLn2) then exit 'invisible
 if CurLn2>=CharHeight then exit 'looks like invisible too??? (by some apps)
 CurOffs=CRT_DATA(0xF) or shl(CRT_DATA(0xE),8) 'offset from videomem start (in chars)
 w=CurOffs-pos : if w>=RowCount*ColCount then exit 'invisible on current screen
 result=true
end

//Text modes 0-3 (bitmask-based rendering)
procedure RenderTextModes
 dim x as integer, y as integer, i as integer, char as byte, pos as integer
 dim attrf as byte, attrb as byte, attrmask as byte
 //change image size, if needed
 image.Width=Width : image.Height=Height
 vidmem.Changed=false 'mark video memory not changed 
 pos=(CRT_DATA(0xD) or shl(CRT_DATA(0xC),8))*2 'hardware-scroll offset
 vidmem.pos=pos 'video memory start
 //precalc attribute mask
 if (MODE_VALUE and 0x20)=0 then attrmask=0xF0 else attrmask=0x70
 //char rendering (cycle by rows/columns)
 for y=0 to Height-1 step CharHeight
  for x=CharWidth-1 to Width-1 step CharWidth
   //read char code and attribute from video memory
   char=vidmem.Byte : chargen.pos=char*8 : attrf=vidmem.Byte
   attrb=shr(attrf and attrmask,4) : attrf=attrf and 0xF
   //char rendering by bitmask 8x8 from chargen
   image.DrawBitMask(x,y,-CharWidth,CharHeight,chargen.Int64, _
         pix.Palette(attrf),pix.Palette(attrb))
 next x : next y
 //hardware cursor rendering (if visible)
 if (BlinkFlag) or (not IsCursorVisible) then exit
 attrf=vidmem.Byte(pos+CurOffs*2+1) and 0xF //attrib (cursor color)
 y=CurOffs/ColCount : x=CurOffs-(y*ColCount) //position in screen coordinates (row/col)
 y=y*CharHeight : x=x*CharWidth //position in pixels
 for i=y+CurLn1 to y+CurLn2 'rendering (solid lines of foreground color)
  image.DrawBitMask(x,i,8,1,0xFF,pix.Palette(attrf),pix.Palette(attrf))
 next i
end

//Graph modes 4-6 (decoder-based rendering)
procedure RenderGraphModes
 dim i as integer, j as integer, k as integer
 //change image size, if needed
 image.Width=Width : image.Height=Height
 //update pixel decoder settings if needed
 if pix.changed then
    j=0 : k=0 : pix.PixelCount=Width 
    select case VideoMode
    case 4 to 5 '320x200x2
      for i=0 to shr(pix.PixelCount,2)-1
       pix.PixelOffset(j)=6+k : pix.PixelMask(j)=3 : j=j+1
       pix.PixelOffset(j)=4+k : pix.PixelMask(j)=3 : j=j+1
       pix.PixelOffset(j)=2+k : pix.PixelMask(j)=3 : j=j+1
       pix.PixelOffset(j)=0+k : pix.PixelMask(j)=3 : j=j+1
      k=k+8 : next i 
    case 6 '640x200x2
      for i=0 to shr(pix.PixelCount,2)-1
       pix.PixelOffset(j)=7+k : pix.PixelMask(j)=1 : j=j+1
       pix.PixelOffset(j)=6+k : pix.PixelMask(j)=1 : j=j+1
       pix.PixelOffset(j)=5+k : pix.PixelMask(j)=1 : j=j+1
       pix.PixelOffset(j)=4+k : pix.PixelMask(j)=1 : j=j+1
       pix.PixelOffset(j)=3+k : pix.PixelMask(j)=1 : j=j+1
       pix.PixelOffset(j)=2+k : pix.PixelMask(j)=1 : j=j+1
       pix.PixelOffset(j)=1+k : pix.PixelMask(j)=1 : j=j+1
       pix.PixelOffset(j)=0+k : pix.PixelMask(j)=1 : j=j+1
      k=k+8 : next i 
    end select
 end if
 //calc start offset of videobuffer //TODO - something wrong here (G-Axe etc)
 k=CRT_DATA(0xD) or shl(CRT_DATA(0xC),8) 'hardware scroll
 //render lines
 j=0 : for i=0 to shr(Height,1)-1
    vidmem.pos=k+i*LineSize 'first part of screen (even lines)
    pix.Execute(vidmem.Object,image.Object,j) : j=j+1
    vidmem.pos=k+i*LineSize+0x2000 'second part of screen (odd lines)
    pix.Execute(vidmem.Object,image.Object,j) : j=j+1
 next i
 //finishing
 vidmem.Changed=false 'mark video memory not changed 
 pix.Changed=false 'mark pixel decoder not changed
end

//Rendering event handler (50Hz by default)
function RenderEvent(freq as integer,eventid as dword) as boolean
 result=true 'need next event call
 'render screen only if something changed
 if (Changed) or (vidmem.Changed) then
 select case VideoMode
  case 0 to 3 : RenderTextModes 'text mode screens 
  case 4 to 6 : RenderGraphModes 'graph mode screens
  end select 
 Changed=false
 'output result
 pc.DrawScreen(image.Object,Aspect) 
 end if
end

//Inversion blink event (4Hz by default)
function BlinkEvent(freq as integer,eventid as dword) as boolean
 result=true 'need next event call
 if IsCursorVisible then : BlinkFlag=not(BlinkFlag) : Changed=true : end
end

'---------------------------- DEVICE Interface --------------------------------

//Device initialization
public function DEV_INIT(stream as object,byref EventFreq as integer) as boolean

 //parent call
 if not DEV_INIT(stream,EventFreq) then exit(false)
 if EventFreq<100 then EventFreq=100

 //init video memory by parameters
 vidmem.Size=PARAM_MEMSIZEKB*1024
 vidmem.BaseAddress=PARAM_MEMADDR 
 vidmem.AddressRange=PARAM_MEMRANGE
 vidmem.AddressMask=vidmem.Size-1

 //register 50Hz rendering event
 pc.NewFreqEvent(50)=RenderEvent '50Hz rendering
 pc.NewFreqEvent(4)=BlinkEvent   '4Hz blinking rendering

 //success
 result=true

end 

//Device finalization
public procedure DEV_DONE(stream as object)

 //clear data
 vidmem.Size=0 : image.height=0 : pix.Reset

 //parent call
 DEV_DONE(stream)

end

