CRTVIEW (На Turbo PASCAL можно неплохо обращаться к памяти экрана)

Перейти вниз

CRTVIEW (На Turbo PASCAL можно неплохо обращаться к памяти экрана)

Сообщение автор _KROL в Пт Июл 28, 2017 8:05 am

(вырезано из темы)
Где это ты ТАК? Сплошной BASIC Smile
За такую фигню я и школьный курс информатики не люблю. Однако у нас там только Pascal ABC, и, если нужно к олимпиадам, немного Free Pascal. Но изучение даже PABC идёт на основном уровне. Почему только я в справку заглядывал??? Мало кто в общем разбирается в этом.
Однако кроме PABC я люблю Turbo Pascal. На нём можно, к примеру, неплохо обращаться к памяти экрана:
Код:
type tchratr=record
c,a:char;
end;

var c80_scr:array[1..25,1..80] of tchratr absolute $b800:0;
Вот мною созданный CRTVIEW(вообще без модулей Wink ):
Код:
var s:string;
const disable=1; enable=0;
type tchratr=record
c,a:char;
end;
var noblinking,nocolor,fastdraw,waitkey,direction,mode,cls,i,j,_x,_y:byte; f:text;
c80_scr:array[1..25,1..80] of tchratr absolute $b800:0; t:array[1..2] of char;
videomode:byte absolute $40:$49;

procedure info;
begin
 writeln('CRT Screens Viewer v.1 (by _KROL)');
 writeln('USE: ',paramstr(0),' (file) [Settings]');
 writeln('Settings(started from "/","" or "-"):');
 writeln('B - no blinking');
 writeln('C - no color');
 writeln('D - fast draw(Warning! Can be danger for corrupted files.)');
 writeln('F?* - load standart videofont (?: 4 - 8x14, 6 - 8x16; *: font block)');
 writeln('K - wait key after draw');
 writeln('M? - change reading file mode');
 writeln(' (?: 0 - simple; 1 - get xy(binary) in file begining; 2 - too(x,CR,y,CR,...) )');
 writeln('R - change file read direction (no - Char,Atrr; yes - Attr,Char)');
 writeln('X - clear screen before return');
 halt;
end;

procedure scrrefresh(r:byte); assembler;
 asm
  mov ah,$12
  mov al,r
  mov bl,$36
  int $10
 end;

procedure blinking(e:byte); assembler;
 asm
  mov ax, 1003h
  mov bl, e
  int 10h
 end;
 
procedure loadfont(fn,blk:byte); assembler;
 asm
  xor ax,ax
  mov al,videomode
  int $10
  mov ah,$11
  mov al,fn
  mov bl,blk
  int $10
 end;

procedure paramerr;
 begin
  writeln('Unknown parameter: ',s);
  halt;
 end;

begin
 if paramcount=0 then
  info;
 noblinking:=0;
 nocolor:=0;
 fastdraw:=0;
 waitkey:=0;
 direction:=0;
 mode:=0;
 cls:=0;
 if paramcount>1 then
  for i:=2 to paramcount do
   begin
    s:=paramstr(i);
    if (not(s[1] in ['/','\','-']))or(length(s)=1) then
     paramerr;
    if length(s)=2 then
     case upcase(s[2]) of
      'B': noblinking:=1;
      'C': nocolor:=1;
      'D': fastdraw:=1;
      'K': waitkey:=1;
      'R': direction:=1;
      'X': cls:=1;
      '?': info;
     else
      paramerr;
    end
    else
    if length(s)=3 then
     case upcase(s[2]) of
      'M':
       if s[3] in ['0'..'2'] then
        mode:=ord(s[3])-48
       else
        begin
         writeln('Incorrect read mode!');
         paramerr;
        end;
     else
      paramerr;
    end
    else
    if length(s)=4 then
     case upcase(s[2]) of
      'F':
       if s[4] in ['0'..'7'] then
        case s[3] of
         '4': loadfont(1,ord(s[4])-48);
         '6': loadfont(4,ord(s[4])-48);
         else
          begin
           writeln('Not correct font size!');
           paramerr;
          end;
        end
       else
        begin
         writeln('Not correct font block!');
         paramerr;
        end;
     else
      paramerr;
    end
    else
     paramerr;
   end;
 s:=paramstr(1);
 assign(f,s);
 {$i-}reset(f);{$i+}
 if ioresult<>0 then
  begin
   writeln('File open error! (',s,')');
   halt;
  end;
  
 blinking(noblinking);
 if fastdraw=1 then scrrefresh(disable);
 _x:=80;
 _y:=25;
 case mode of
  1:
   begin
    read(f,t[1],t[2]);
    _x:=ord(t[1])+(ord(t[2]) shl 8);
    read(f,t[1],t[2]);
    _y:=ord(t[1])+(ord(t[2]) shl 8);
   end;
  2:
   begin
    readln(f,_x);
    readln(f,_y);
   end;
 end;
 if (_x>80)or(_y>50) then
  begin
   writeln('Incorrect screen size!');
   paramerr;
  end;
 for j:=1 to _y do
  for i:=1 to _x do
   begin
    case direction of
     0: read(f,c80_scr[j,i].c,c80_scr[j,i].a);
     1: read(f,c80_scr[j,i].a,c80_scr[j,i].c);
    end;
    if nocolor=1 then
     c80_scr[j,i].a:=#$f;
   end;
 if fastdraw=1 then scrrefresh(enable);
 close(f);
 if waitkey=1 then
  asm
   xor ax,ax
   int $16
  end;
 if cls=1 then
  asm
   xor ax,ax
   mov al,videomode
   int $10
  end;
end.

_KROL

Сообщения : 90
Дата регистрации : 2017-07-28
Возраст : 19
Откуда : Беларусь

Посмотреть профиль

Вернуться к началу Перейти вниз

Вернуться к началу

- Похожие темы

 
Права доступа к этому форуму:
Вы не можете отвечать на сообщения