freepascal.compiler/demo/freebsd/fontdemo.pas

Program FontDemo;
{ FontDemo.pas, by Marco van de Voort (C) 2000-2001

Compiler: 1.0.5 or 1.1 after 20-01-2001
Target  : FreeBSD 4.x+ with 16x8 font. 3.x untested  (syscons driver)

Demonstrate font modification with the console driver "syscons".
This program doesn't work under X or over telnet.

The purpose of the program is to demonstrate the procedures that change the
font. The demonstration assume a 80x25 console. Framebuffer devices or 80x50 
displays (80x50 use 8x8 fonts) require a trivial modification.

The example of mirroring is absurd, but is very visible, so good for
demonstration. The real use is to load the font, change a few characters
(linedrawing, (C) characters, force existance of umlaute or tremas for the
duration of the application. 

Note that if you switch to a different vty while the font is mirrored, that
vty is also mirrored.

Root can restore the font via a network device with:

vidcontrol -f 8x16 "fontname in /usr/share/syscons/fonts"   < /dev/ttyv1 

The program saves the font, and will terminate and restore the font when
SIGUSR2 is received, unless -n is specified.

killall -USR2 fontdemo 

}


Uses Console,{$ifdef ver1_0}Linux{$else}Baseunix{$endif},GetOpts;

{$ifdef ver1_0} 
 function fpnanosleep;
 begin
   nanosleep;
 end; 
{$endif}

procedure MirrorFont8(var Data;Count:longint); assembler;
{Mirrors on a bit level "Count" bytes in typeless variable "Data"}

asm
	 mov data,%esi
	 movl Count,%edx
.LLoop1: movb (%esi),%bl
	 movl $8,%ecx
.LLoop2: shr  $1,%bl                                 
	 rcl  $1,%al
         loop .LLoop2
         movb %al,(%esi)	
	 incl %esi
	 decl %edx
         jne .LLoop1
end['EAX','EBX','ECX','EDX','ESI'];


procedure GoLeft(var Data;Count:longint;shcnt:longint); assembler;
{Mirrors on a bit level "Count" bytes in typeless variable "Data"}

asm
	 mov data,%esi
         mov data,%edi
	 mov shcnt,%ecx
	 movl Count,%edx
	 xorl %eax,%eax
.LLoop1: lodsb
	 shl  %cl,%eax
	 stosb
	 incl %esi
 	 incl %edi
	 decl %edx
         jne .LLoop1
end['EAX','EBX','ECX','EDX','ESI'];

procedure GoRight(var Data;Count:longint;shcnt:longint); assembler;
{Mirrors on a bit level "Count" bytes in typeless variable "Data"}

asm
	 mov data,%esi
         mov data,%edi
	 mov shcnt,%ecx
	 movl Count,%edx
	 xor %eax,%eax
.LLoop1: lodsb
	 shr  %cl,%eax
	 stosb
	 incl %esi
         incl %edi
	 decl %edx
         jne .LLoop1
end['EAX','EBX','ECX','EDX','ESI'];

procedure DoAlt(var Data;Count:longint;shcnt:longint;alt:integer); assembler;
{Mirrors on a bit level "Count" bytes in typeless variable "Data"}

asm
	 mov alt,%ecx
	 mov data,%esi
         mov data,%edi
	 add %ecx,%esi
	 add %ecx,%edi
	
	 mov shcnt,%ecx
	 movl Count,%edx
	 xorl %eax,%eax
.LLoop1: lodsb
	 mov %edx,%ebx
	 and  $1,%ebx
         test %ebx,%ebx
         je   .Lgoleftalt1
	 shl  %cl,%eax
         jmp  .Lgoleftalt2
.Lgoleftalt1:
	 shr  %cl,%eax
.Lgoleftalt2:
	 stosb
	 incl %esi
 	 incl %edi
	 decl %edx
         jne .LLoop1
end['EAX','EBX','ECX','EDX','ESI'];

procedure stripbits (var Data;Count:longint); assembler;
{ "Compresses" a byte. 76543210 -> x764310x where x=0 (but 0 was already
used to indicate bit number :-)

Needed for a rotating effect. (Character rotating round vertical axis) 
Does this for "Count" bytes in "Data".
}

asm
	 mov data,%esi
	 movl Count,%edx
.LLoop1: movb (%esi),%cl
	 and  $219,%ecx
	 mov  %ecx,%eax
	 mov  %ecx,%ebx
	 and  $24,%eax
         and  $3,%bl	
       	 shr  $1,%al
	 or   %bl,%al
	 shl  $1,%al
	 mov  %ecx,%ebx
         and  $192,%bl	
       	 shl  $1,%al
	 or   %bl,%al
	 shr  $1,%al
         movb %al,(%esi)	
	 incl %esi
	 decl %edx
         jne .LLoop1
end['EAX','EBX','ECX','EDX','ESI'];

procedure silloute (var Data;Count:longint); assembler;
{Iterates through "Count" bytes of "Data" and sets a byte to $48 if it is
not zero. If you would rotate a character round vertical axis through 90
degrees, this is about how it looks like}

asm
	 mov data,%esi
	 movl Count,%edx
.LLoop1: movb (%esi),%al
	 mov  $48,%ecx
	 test %al,%al
	 je   .Lfurther
         mov  %cl,%al
.Lfurther:
         movb %al,(%esi)	
	 incl %esi
	 decl %edx
         jne .LLoop1
end['EAX','EBX','ECX','EDX','ESI'];

var Originalfont : Fnt16;	  {Font on startup, to be saved for restore}
    StopIt       : BOOLEAN;	  {Becomes TRUE when SIGUSR2 is received}
    RestoreOnExit : Boolean;   	  {Should font be restored on exit?}

procedure OkThatsEnough(sig:longint);cdecl;

begin
 StopIt:=TRUE;
end;

procedure dorotate;

{ The animation order of the 5 distinctive states, -> 8 changes is one
rotation}
Type RotStatesType   = array[0..7] of longint;

const RotStates : RotStatesType=(0,1,4,3,2,3,4,1);

{5 states:
- 0 is mirrored,
- 1  mirrored "compressed"
- 2 is normal,  
- 3 normal "compressed", 
- 4 "silloutte"}

var fnts    : array[0..4] of fnt16;
    I	    : Longint;
    iin,oout: timespec;
     
begin
   iin.tv_nsec:=250000000;
   iin.tv_sec:=0;
   fnts[2]:=OriginalFont;
   fnts[0]:=fnts[2];			// Keep a copy.
   MirrorFont8(fnts[0],sizeof(fnt16));	// Mirror every byte at bitlevel
   fnts[1]:=fnts[0];
   stripbits(fnts[1],sizeof(fnt16));
   fnts[3]:=fnts[2];
   stripbits(fnts[3],sizeof(fnt16));
   fnts[4]:=fnts[2];
   silloute(fnts[4],sizeof(fnt16));
   i:=4;
   Repeat
     PIO_FONT8x16(0,fnts[RotStates[I and 7]]); 		// Activate the mirrored set
     fpnanosleep(@iin,@oout);
     inc(i);
   until StopIt;
 end;

procedure upanddown(Mini:BOOLEAN);

var 
    fnts      : array[1..4] OF fnt16;
    inn,outn  : Timespec;
    i	      : longint;
    Mask      : Longint;

begin
   fnts[2]:=OriginalFont;
   inn.tv_nsec:=50000000;
   inn.tv_sec:=0;
   fnts[4]:=fnts[2];   {Make three copies}
   fnts[1]:=fnts[2];
   fnts[3]:=fnts[2];

   {Move one of them one byte up in memory. Font is one bit lower}

   move (fnts[1],fnts[1].fnt8x16[1],SIZEOF(Fnt16)-1);
   
   {Move another of them one byte down in memory. Font is one bit higher}
   IF Mini THEN 
    Begin
     Mask:=1;
     move (fnts[2].fnt8x16[1],fnts[2],SIZEOF(Fnt16)-1);
    end
   else
    begin
     move (fnts[3].fnt8x16[1],fnts[3],SIZEOF(Fnt16)-1);
     Mask:=3;
    end;

   Repeat 
     fpnanosleep(@inn,@outn);
     pIO_FONT8x16(0,fnts[1 + (I and Mask)]);            
     inc(I); 
   until StopIt;
end;

procedure LeftAndRight;

var 
    fnts      : array[1..4] OF fnt16;
    inn,outn  : Timespec;
    i	      : longint;
    Mask      : Longint;

begin
   fnts[2]:=OriginalFont;
   inn.tv_nsec:=50000000;
   inn.tv_sec:=0;
   fnts[4]:=fnts[2];   {Make three copies}
   fnts[1]:=fnts[2];
   fnts[3]:=fnts[2];

   {Move one of them one byte up in memory. Font is one bit lower}

   Goright(Fnts[1],SIZEOF(FNT16),2);
   GoLeft( Fnts[3],SIZEOF(FNT16),2);
   Repeat 
     fpnanosleep(@inn,@outn);
     pIO_FONT8x16(0,fnts[1 + (I and 3)]);            
     inc(I); 
   until StopIt;
end;

procedure doalternate;

var 
    fnts      : array[0..5] OF fnt16;
    inn,outn  : Timespec;
    i	      : longint;
    Mask      : Longint;

begin
   fnts[2]:=OriginalFont;
   inn.tv_nsec:=500000000;
   inn.tv_sec:=0;
   fnts[4]:=fnts[2];   {Make three copies}
   fnts[1]:=fnts[2];
   fnts[3]:=fnts[2];

   {Move one of them one byte up in memory. Font is one bit lower}
   doalt(fnts[1],SIZEOF(FNT16) div 2,2,1);
   doalt(fnts[3],SIZEOF(FNT16) div 2,2,0);
   Repeat 
     fpnanosleep(@inn,@outn); 
     writeln(1 + (I and 3));
     pIO_FONT8x16(0,fnts[1 + (I and 3)]);            
     inc(I); 
   until StopIt;
end;

procedure JustMirror;

var fnt : Fnt16;

begin
  fnt:=OriginalFont;
  MirrorFont8(fnt,sizeof(fnt16));
  pIO_FONT8x16(0,fnt);        
  IF RestoreOnExit THEN    
  Repeat 
  until StopIt;
end;

var DoThis 	  : Longint;
    
    c		  : Char;
begin
 DoThis:=0;
 RestoreOnExit := TRUE;
 if PhysicalConsole(0) then		// a vty?
  begin
   REPEAT
    c:=GetOpt('n012345');			// Commandline processing
    IF c IN ['0'..'5'] Then
     DoThis:= ORD(c)-48;
    IF c='n' THEN
     RestoreOnExit:=FALSE;
   UNTIL C=EndOfOptions;

   StopIt:=false;			// Turns true on signal USR2
   GIO_FONT8x16(0,OriginalFont);	// Get font from videocard.
   fpSignal(SIGUSR2,@OkThatsEnough);	// Install handler for sigusr2.

   CASE DoThis OF			// Call the font routines
    0 : DoRotate;
    1 : UpAndDown(TRUE);
    2 : JustMirror;
    3 : UpAndDown(FALSE);
    4 : LeftAndRight;
    5 : doAlternate;
    END;

   IF RestoreOnExit THEN		// clean up if required.
    PIO_FONT8x16(0,OriginalFont);	  
  end;
end.