DASM
DExecHW/Video.pm
Go to the documentation of this file.
00001 #!/usr/bin/perl -w
00002 ##
00003 # Text emulation for the DASM assembler.
00004 # This module provides the video RAM for a text array chip, based on what
00005 # appears to be the video hardware for the assembler.
00006 #
00007 # The chip is 32x12 = 384 bytes for the video array.
00008 #
00009 # The allocation in the window is:
00010 #
00011 #    - 0x000-0x17f : Character array
00012 #
00013 #    - 0x180-0x27f : Character definitions
00014 #
00015 #    - 0x280-0x281 : Background colour
00016 #
00017 # Bit mapping:
00018 #
00019 #    `ccccccccbiiiiiii`
00020 #
00021 #    - `iiiiiii` @n
00022 #      Character index.
00023 #
00024 #    - `b` @n
00025 #      Blinking.
00026 #
00027 #    - `cccccccc` @n
00028 #      Colour, in the form `ffffbbbb`, each of which takes the form `hrgb`:
00029 #      - `h` @n
00030 #        Highlight (increase by 0x55).
00031 #      - `r` @n
00032 #        Red component (value 0xAA when set)
00033 #      - `g` @n
00034 #        Green component (value 0xAA when set)
00035 #      - `b` @n
00036 #        Blue component (value 0xAA when set)
00037 #
00038 # We actually use the highlight only on the foreground colour, as bold
00039 # in the colour attributes.
00040 #
00041 # @file
00042 # @author Justin Fletcher
00043 #
00044 
00045 package DExecHW::Video;
00046 
00047 use Curses;
00048 
00049 
00050 ## Disable the Curses interface (for debug)
00051 my $disabled = 0;
00052 
00053 
00054 ##
00055 # Construct a new hardware device object.
00056 #
00057 # @param[in]  $proto   This class object, or prototype to add to
00058 # @param[in]  $object  The object to proxy for
00059 # @param[in]  $offset  The offset this object is created for
00060 #
00061 # @return Assembler object
00062 sub new
00063 {
00064     my $proto = shift;
00065     my $object = shift;
00066     my $offset = shift || 0;
00067     my $class = ref($proto) || $proto;
00068     my $self = {
00069             'display' => [
00070                     map { 0 } (0..0x17f)
00071                 ],
00072             'chars'   => [
00073                     map { 0 } (0..0xff)
00074                 ],
00075             'background' => [
00076                     map { 0 } (0..0x1)
00077                 ],
00078             
00079             'width' => 32,
00080             'height' => 12,
00081         };
00082     
00083     bless $self, $class;
00084     
00085     
00086     return $self;
00087 }
00088 
00089 
00090 ##
00091 # Start up the hardware.
00092 #
00093 # We perform all output through the Curses library.
00094 #
00095 # @param[in] $self   Object
00096 sub start
00097 {
00098     my ($self) = @_;
00099 
00100     if (!$disabled)
00101     {
00102         Curses::initscr();
00103         
00104         if (!Curses::has_colors())
00105         {
00106             Curses::endwin();
00107             die "No colours available for video driver\n";
00108         }
00109         
00110         Curses::start_color();
00111         my @colours = (
00112                 Curses::COLOR_BLACK,
00113                 Curses::COLOR_BLUE,
00114                 Curses::COLOR_GREEN,
00115                 Curses::COLOR_CYAN,
00116                 Curses::COLOR_RED,
00117                 Curses::COLOR_MAGENTA,
00118                 Curses::COLOR_YELLOW,
00119                 Curses::COLOR_WHITE,
00120             );
00121         for my $col (0..(8*8-1))
00122         {
00123             Curses::init_pair(1+$col, $colours[$col>>3], $colours[$col & 7]);
00124             
00125             # Debugging
00126             if ($disabled)
00127             {
00128                 printf "InitColour %i: fg=%i, bg=%i\n",
00129                         $col, $colours[$col>>3], $colours[$col & 7];
00130             }
00131         }
00132 
00133         $self->{'win'} = Curses::newwin($self->{'height'},
00134                                         $self->{'width'},
00135                                         0, 0);
00136         #Curses::box( $self->{'win'}, 0,0);
00137 
00138         Curses::refresh( $self->{'win'} );
00139     }
00140 }
00141 
00142 
00143 ##
00144 # Stop the hardware.
00145 #
00146 # @param[in] $self   Object
00147 sub stop
00148 {
00149     my ($self) = @_;
00150 
00151     if (!$disabled)
00152     {
00153         Curses::endwin();
00154     }
00155 }
00156 
00157 
00158 
00159 ##
00160 # Return the size of of the implementation.
00161 #
00162 # @param[in] $self   Object
00163 #
00164 # @return Size of the hardware implementation in words
00165 sub window
00166 {
00167     my ($self) = @_;
00168 
00169     return 0x282;
00170 }
00171 
00172 
00173 ##
00174 # Read value
00175 #
00176 # @param[in] $self   Object
00177 # @param[in] $offset Offset of register within window
00178 # @param[in] $exec   DExec object opon which this object is operating
00179 #
00180 # @return value of this register
00181 sub read
00182 {
00183     my ($self, $offset, $exec) = @_;
00184 
00185     if ($offset < 0x180)
00186     {
00187         $value = $self->{'display'}->[$offset];
00188     }
00189     elsif ($offset < 0x180+0x100)
00190     {
00191         $value = $self->{'chars'}->[$offset-0x180];
00192     }
00193     elsif ($offset < 0x180+0x100+2)
00194     {
00195         $value = $self->{'background'}->[$offset-0x180-0x100];
00196     }
00197     
00198     return $value;
00199 }
00200 
00201 
00202 ##
00203 # Write value
00204 #
00205 # @param[in] $self   Object
00206 # @param[in] $offset Offset of register within window
00207 # @param[in] $exec   DExec object upon which this object is operating
00208 # @param[in] $value  Value to write
00209 #
00210 # @return ignored
00211 sub write
00212 {
00213     my ($self, $offset, $exec, $value) = @_;
00214 
00215     if ($offset < 0x180)
00216     {
00217         $self->{'display'}->[$offset] = $value;
00218         
00219         my $bg = ($value >> 8) & 0x7;
00220         my $bgh = $value & (1<<11);
00221         my $fg = ($value >> 12) & 0x7;
00222         my $fgh = $value & (1<<15);
00223         my $blink = ($value & 128);
00224         my $char = ($value & 0x7f);
00225         
00226         if (!$disabled)
00227         {
00228             Curses::attron( $self->{'win'},
00229                             Curses::COLOR_PAIR(1+$fg*8 + $bg) |
00230                                 ($fgh ? Curses::A_BOLD : 0) |
00231                                 ($blink ? Curses::A_BLINK : 0));
00232         }
00233     
00234         my $y = int($offset / $self->{'width'});
00235         my $x = int($offset % $self->{'width'});
00236 
00237         if (!$disabled)
00238         {
00239             Curses::addch($self->{'win'}, $y, $x, $char);
00240 
00241             Curses::refresh( $self->{'win'} );
00242         }
00243         else
00244         {
00245             print "Write $value to $x,$y (char=$char, fg=$fg, bg=$bg, blink=$blink)\n";
00246         }
00247     }
00248     elsif ($offset < 0x180+0x100)
00249     {
00250         $self->{'chars'}->[$offset-0x180] = $value;
00251     }
00252     elsif ($offset < 0x180+0x100+2)
00253     {
00254         $self->{'background'}->[$offset-0x180-0x100] = $value;
00255     }
00256 }
00257 
00258 
00259 ##
00260 # Get the symbol name for an offset
00261 #
00262 # @param[in] $self   Object
00263 # @param[in] $offset Offset of register within window
00264 #
00265 # @return symbol name to use
00266 # @retval undef for a default symbol
00267 # @retval "" for no symbol
00268 sub symbol
00269 {
00270     my ($self, $offset) = @_;
00271     
00272     return "";
00273 }
00274 
00275 # Must return 1
00276 1;