В этом приложении приводится орисание работы и текст программы, предназначенной для редактирования существующих или создания новых векторных BCI— шрифтов. Такие шрифты используются для вывода текстовых сообщений стандартными процедурами OutText и OutTextXY, а также процедурой OutString из модуля F_GrText в графическом режиме работы экрана. Описание формата BCI— шрифтов приведено в п. 1.2. Программа рассчитана на работу с мышью и экраном типа EGA/VGA.
П3.1. Интерфейс с пользователем
Для запус ка программы следует дать команду
fontedit [FName]
В квадратных скобках указан необязательный параметр, определяющий имя уже существующего CHR— файла.
В момент запуска программа проверяет параметры обращения и, если указано имя FName, настраивается на редактирование шрифта из этого файла. Например, обращение
fontedit trip
заставит программу загрузить BCI— шрифт из файла trip.chr с целью редактирования стандартного шрифта TriplexFont (добавления новых символов или изменения старых). Вы можете задать имя с предшествующим ему маршрутом поиска CHR — файла на диске (если файл имеет стандартное расширение CHR, это расширение можно не указывать — см. пример выше).
Если параметр обращения отсутствует, программа запрашивает имя файла. В этот момент Вы должны ввести имя, если хотите редактировать шрифт, или нажать Enter, если хотите создать новый.
После правильной загрузки данных из CHR—файла экран приобретет вид, показанный на рис.ШЛ.
Верхняя строка содержит опции меню, левую часть экрана занимает поле редактора, а правую часть — таблица всех символов из редактируемого BGI— шрифта.
Для создания нового или изменения существующего символа используется поле редактора. Это поле расчерчено точками, определяющими локальные координаты символа — любой векторный элемент представляет собой вектор, соединяющий две произвольные точки (два узла) поля редактора. Каждое изменение поля редактора автоматически отображается в уменьшенном виде (точнее, с масштабными коэффициентами 1,1) в небольшом окне повторения ниже поля редактора.
Таблица символов предназначена для выбора очередного символа перед его загрузкой в поле редактора, а также для указания того места в ASCII— таблице, куда будет помещен вновь созданный или отредактированный в этом поле символ. Ниже таблицы создается небольшое окно, в котором показывается ASCII—mop, выбираемого элемента. Так как стандартные векторные шрифты не содержат символов с ASCII— кодами от 0 до 31 и символа #255, соответствующие позиции в таблице заполняются матричными символами шрифта DefaultFont и изображаются пониженной яркостью. При желании Вы можете создать векторный символ для любого ASCII— кода, в том числе и для этих позиций таблицы.
Рис.Ш. 1. Вид экрана редактора шрифтов Опции меню имеют следующий смысл:
• «Из таблицы» — активизирует выбор из таблицы символа," который требуется загрузить в поле редактора; - '
• «В таблицу» — выбирает то место в таблице ASCII1- кодов, в которое будет ггомвщвй вновь созданный или отредактированный символ; \ "
• «Очистить» -• очищает поле редактора;
• «Образец» — активизирует выбор из таблицы символа, Который будет слухить образцом для вновь разрабатываемого; образец выводится в рабочем поле пониженной яркостью и никак не влияет на новый символ;
• «Сохранить» — сохраняет текущее состояние шрифта в файле;
• «Конец» — завершает работу программы и возвращает управление ДОС; если к этому
моменту в ASCII— таблице были сделаны несохраненные на диске изменения, шрифт
автоматически сохраняется в файле.
Работа программы управляется мышью, две кнопки которой отождествляются со следующими действиями:
• левая кнопка: выбирает продолжение из меню, начинает или заканчивает .формиро-" вание очередного векторного элемента в поле редактора, выбирает текущий элемент в таблице символов;
• правая кнопка: отменяет формирование нового векторного элемента, удаляет (стирает) векторный элемент, отменяет выбор из таблицы символов, перемещает в новое положение правую границу символа в поле редактора.
Для редактирования (изменения) существующего векторного символа выберите- в меню продолжение «Из таблицы», сместите мышью курсор таблицы {белый прямоугольник) к нужному символу и нажмите левую кнопку — поле редактора очистится и в него будет помещена совокупность векторов, определяющих начертание нужного символа. Замечу, что все последующие изменения символа в поле редактора никак не связываются с редактируемом символом до тех пор, пока вновь созданный символ не будет тгомещен на ?го место. Более того, из поля редактора можно переносить новый символ на любое место — таким способом, например, можно быстро заполнить ту часть русского алфавита, которая по наяертанию совпадает с латиницей.
Если Вы хотите создать новый символ, не имеющий сходства с ранее еозданнымйг очистите поле редактора с помощью продолжения «Очистить». Возможно, Ры захотите посмотреть на детали реализации того или иного ранее созданного символа, но не хотите, чтобы его векторы «мешали» вновь создаваемому — в этом случае используйте продолжение «Образец» (например, можно загрузить как образец латинскую букву Р при создании символа
Ф).
Для добавления нового вектора подведите указатель мыши к узлу, от которого он должен начинаться, и нажмите левую кнопку — указатель исчезнет, что сигнализирует о «захвате» узла. Указатель появится вновь только после отпускания кнопки, но будет уже представлять собой небольшой прямоугольник, показывающий границы чувствительности мыши. При перемещении такого указателя по рабочему полю за ним будет тянуться «резиновая нить». В этом состоянии подведите указатель ко второму узлу так, чтобы этот узел попал в прямоугольник указателя, и вновь нажмите левую кнопку — указатель приобретет нормальный вид, а в поле редактора добавится новый вектор. Если Вы передумаете и не захотите добавить вектор, нажмите правую кнопку — «резиновая нить» исчезнет без каких-либо последствий.
Для удаления какого-либо вектора подведите к нему указатель и нажмите правую кнопку. Если мышь спозиционирована достаточно точно, вектор ^удет стерт, а стандартная маска указателя заменится на небольшой прямоугольник. Если теперь, не отпуская кнопки, перемещать указатель в рабочем поле, будут стираться все векторы, на коюрые покажет этот указатель. После отпускания кнопки указатель восстановит стандартный вид и мышь перестанет стирать векторы.
После того, как Вы отредактируете символ нужным образом, выберите в меню продолжение «В таблицу» и поместите символ на нужное место.
На некотором расстоянии справа от символа в поле редактора формируется вертикальная линия, показывающая текущую ширину символа. Положение этой линии автоматически изменяется, если вновь созданный векторный элемент выходит за нее. Вы можете установить положение линии вручную, для этого подведите к ней указатель и нажмите правую кнопку — указатель изменит свой вид на небольшой прямоугольник. В таком состоянии перемещайте мышь, удерживая нажатой ее правую кнопку — линия будет отслеживать горизонтальное
положение указателя. Перед тем как поместить отредактированный символ в таблицу, Вы должны убедиться в том, что эта линия задает правильный межсимвольный промежуток.
П3.2. Описание программы
Работа программы проходит в три этапа и реализуется процедурами /nit. Run и Done. На этапе выполнения процедуры uii't осуществляются следующие действия:
• вводится имя редактируемого или вновь создаваемого CHR— файла, содержащего нужный векторный шрифт (процедура Namelnputf;
• если файл уже существует, программа проверяет его структуру и считывает данные (процедура ReadData), в противном случае — запрашивает параметры вновь создаваемого файла и готовит его описание (процедура NewFUef;
• переводит экран в графический режим, инициирует мышь и готовит для нее графические указатели, расчерчивает поле редактирования, выводит таблицу символов и готовит меню для работы с мышью (процедура BuildScreenf. Основная работа реализуется процедурой Run. тело которой состоит из бесконечного цикла While True do begin ... end. В ходе этого цикла непрерывно сканируется состояние мыши, и в зависимости от результатов сканирования выполняются следующие действия:
• если мышью выбран один из элементов меню (т.е. указатель подведен к соответствующей надписи и нажата левая кнопка мыши), вызывается одна из процедур GetChar, SetChar, ClearWE, Pattern, SaveFont или Exit в зависимости от сделанного выбора;
• если нажата левая кнопка мыши, а указатель при этом был в поле редактора, вызывается процедура MouseInNed, проверяющая выбор того или иного узла поля редактора; если узел выбран, он становится исходной точкой и от него вслед за указателем мыши будет тянуться «резиновая нить»; если «резиновая нить» уже была сформирована предыдущим обращением к MouseInNed, обращение к этой процедуре вызовет формирование нового векторного элемента редактируемого символа;
• если нажата правая кнопка и указатель располагался в поле редактора, вызывается процедура MouseInLine, проверяющая выбор того или иного вектора и осуществляющая его стирание, если вектор выбран;
• если не нажата ни одна кнопка, но мышь изменила свое положение, будет вызвана процедура MouseMove, реализующая «резиновую нить».
Завершающий этап работы программы реализуется процедурой Done. В ходе ее выполнения вызывается процедура SaveFont для сохранения в файле сделанных изменений, и восстанавливается текстовый режим работы экрана.
В программе используются процедуры и функции из модулей F_GrText (для формирования меню и вывода номера элемента ASCII— таблицы), F_Mouse (для обслуживания мыши и контроля выбора элемента меню) и F_Anti (для автоматической защиты программы от нападения вирусов).
1$Х+} ^——————————————————————————————+
¦ Редактор векторных шрифтов формата CHR ¦
+--------—----—--—-----------—----------——+
;
Uses CRT,Graph,F_GrText,F_Mouse,F Anti;
{
Глобальные определения
}
type
TChar4 = array [1..4] o? Char;
TFontHead = record {Структура заголовка шрифта}
case Byte of
0:(FontFileID: TChar4) ;
1:(B: array [1..128] of byte; ;
end;
TFontPara = record {Блок параметров шрифта}
case Byte of
ParPrefix : Char; {Символ "+"}
CharsCount: Word; {Количество символов а шрифте}
Reservl : Byte; (He используется)
firstChar : Byte; {Код первого символа}
DataOffset: Word; {Смещение до векторных команд первого -символа}
FillFlag : Byte; (Флаг заливки}
UpperMargin: Byte; {Высота, символов}
Reserv2 : Byte; {He используется}
LowerMargin: Shortint; {Нижняя кромка}
Reserv3 : array [1..5] of Byte?);
1:(H2: array [1..16] of Byte) end;
TOffst = array [0..255] of Word; {Смещения} TWidth = array [0..255] of Byte; {Ширины} TChars = array [0..255] of Pointer; (Данные} TLengD = array [0..255] of Word; {Длина} AW = array [1..255] of Word;
TCooE " record (Векторы рабочего поля}
X1,Y1,X2,X2: Integer;
end;
TMouseMask = array [0..1,0..151 of Word;
var
FontHead TFontHead; {Заголовок файла} HeaderSize: Word; (Смещение блока параметров} FontPara TFontPara; {Параметры шрифта} FileSize Word; {Длина загружаемой части файла} AFileSize: Byte; {Положение FileSize} Offsets TOffst; {Таблица смещений} Widths TWidth; (Таблица ширин} Chars TChars; (Указатели на данные} LengD TLengD; (Длина данных в байтах} F File; {CHR-файл} FName String; {Имя файла} MaxW Byte; {Максимальная ширина символа} MaxH Byte; (Полная высота символа} {——————— рабочее поле ———————}
ХЕ Integer; {Левый верхний угол f/S.} IS Integer;
ХЕ2 Integer; (Правый нижний угод WE) YE2 Integer;
YB Integer; {Ордината базовой линии} WidthX Integer; (Правая граница символа} DXE Integer; {Ширина клетки WE} DYE Integer; {Высота, клетки WE} NVecE Word; {Количество векторов в ИЕ} VecE: array [1..250] of TCooE; {Векторы в ИЕ} (———————— Окно повтора ————————}
XR,YR: Integer; {Координаты окна повтора} HR: Pointer; {Образ пустого окна повтора} {---------- Таблица символов ------------}
XT : Integer; {Левый верхний угол таблица символов} YT : Integer;
DXT : Integer; {Ширина клетки таблицы символов} DYT : Integer; {Высота клетки} {—————————— Мышь -——————————}
dXm,dYm : Integer; {Границы мыши в рабочем поле} CurM: TMouseMask; (Стандартная маска указателя} CurE: TMouseMask; (Маска в рабочем поле} HouseF : Boolean; {Флаг формы указателя мыши}
const
ChangeF: Boolean '» False; {Флаг изменения шрифта} Head: TChar4 - ('P','К',#8,#8) ;
procedure OutChar(XO,YO: Integer; C: Byte; DX,DY: Real);
(Выводит символ С в позицию X,Y с масштабом DX,DY} var
PW:'-AW;
k: Integer;
x,y: Integer;
Procedure Vector(W: Word);
{Рисует очередной вектор символа} vax
хх,уу: Integer;
ор: Word;
begin
{Выделяем Код операции}
ор := W and $8080;
if op=0 then Exit;
W := H acor ор;
(Выделяем координаты}
уу := W shr 8;
хх := W and $FF;
if xx>63 then xx :•= xx-128;
if yy>63 then yy :•= yy-128;
{Поучаеы координаты второй точки}
хх :=• XO+Round(xx*DX) ;
уу :° YO-Round(yy*DY) ;
{Выполняем операцию}
if op-$8080 then Line(X,Y,XX,YY);
X := XX;
У :« YY end; {Vector} {——————}
begin {OutChar}
if LengD[C]"0 then
Exit; {Блокируем вывод не определенных символов}
YO :" YO-DXT div 4;
X :" ХО; {Точка отсчета координат}
У :° YO;
PW :•=• Chars [С]; (Описатель символа}
{Вычерчиваем символ}
for k :» 1 to LengD[C] div 2 do
Vector (PWik]) end; {OutCharXY} _•————————————;
Procedure ClearWinEd;
{Очищает рабочее поле} var
X,Y: Integer;
begin SetViewPort(XE-dXm,YE-dYm,XE2+dXm,YE2+dYm.True) ;
ClearViewPort;
SetViewPort(0,0,GetMaxX,GetMaxY,True;;
/Выводим вертикали/
for X := 0 to MaxW do for Y :» 0 to MaxH do
PutPixel(XE+X*DXE,YE+Y*DYE,White);
{Выводим базовую линию}
SetColor(Cyan);
YB := YE+succ(FontPara.UpperMargin)*DYE;
Line(XE,YB,XE2,YB) ;
{Выводим указатель границы символа}
WidthX := ХЕ;
Line(XE,YE,XE,YE2) ;
{Обводим рамкой}
?etColor(White) ;
Rectangle(ХЕ-dXm,YE-dYm,XE2+dXm,YE2+dYm) end; (ClearffE} _•————————————;
Procedure I nit;
{Запрашивает и вводит имя CHR-файла, вводит данные из файла, инициирует--гря~ фику и создает экран}
Procedure FontRsad. (var Dest; Size: Word);
(Читает из файла F в переменную Dest Size байР я контролирует результат. При ошибке аварийно завершает программу} var
k: Word;
begin
BlockRead(F,Dest,Size,k) ;
if k=Size then Exit;
WriteLnCОшибка при чтении данных из файла!');
Halt end; (FontRead) {—————} Procedure NameInput(var FName: String);
(Вводит и проверяет имя CHR-файла} label
Loop,HeadErr;
var
k: Byte;
begin
Write('Программа редактирования векторных BQI-шрифтов формата CHR. ') ;, WriteLn('<C) 1993 В.В.Фаронов') ;
{Проверяем параметры обращения} if ParamCountoO then
FName := ParamStr(l) else
FName := '';
if FName='' then
begin Loop: (Сюда возврат при ошибке в имени}
Write('Введите имя CHR-файла (*.CHR): ');
ReadLntFName) ;
it FName = ' ' then
begin {Пустой ввод} Write('Создать новый шрифт (Y/N)? ');
ReadLntFMame);
if (FName=") or
(UpCase(FName[1])<>'Y') then Halt;
FName :° '';
Exit
end end;
{Проверяем существование файла) if Pos('.',FName)=0 then FMame := FName+'.CHR' ;
{$!-} {Отключаем контроль lOEtrorf Assign(F,FName);
Reset(F,1); {Пытаемся открыть файл} {$!+} {Восстанавливаем контроль ЮЕггог} if IQResultoO then begin
WriteLn('Файл '+FName+' не найден');
Goto Loop end;
{Читаем заголовок файла} FontRead(FontHead,SizeOf(FontHead)) ;
if FontHead. FontFileIDoHead then begin
WriteLn('Ошибка в заголовке файла!');
Goto Loop end;
{Ищем смещение блока параметров и длину файла'} with FontHead do begin
k := 5; {Начинаем с пятого байта} while (kOizedf (FontHead)) and (B[k]o$lA) do inc(k);
if B[k]=$lA then begin
HeaaerSize := B[k+l]+B[k+2] ehl 8;
FileSize := B[k+7]+B[k+8] ahl 8;
AFileSize := k+7;
{Читаем блок параметров} Seek(F,HeaderSize) ;
FontRead(FontPara,SizeOf(FontPara)) ;
if FontPara.ParPrefix='+' then
Exit {Нормальный выход) else /Her префикса параметров}
Goto HeadErr end end;
{Не найден терминатор CopycightEnd) HeadErr:
Close(F) ;
WriteLn('Ошибка в заголовке файла!');
Goto Loop end; {Каше Input} {—————} Procedure ReadData;
{Читает данные из файла} var
k: Integer;
LastChar: Byte;
begin
with FontPara do begin
LastChar := FirstChar+CharsCount-1;
{Заполняем таблицу смещений} for k := 0 to 255 do
if k in [FirstChar..LastChar] than
FontRead(Off sets[k],2) else
Offsets[k] := 0;
{Заполняем таблицу ширин) MaxW := 0;
for k := 0 to 255 do
if k in [FirstChar..LastChar] then begin
FontRead(Widths[k],1) ;
if Widths[k]>MaxW then
MaxW := Widths(k] end else
Widths[k] :" 0;
if MaxW<20 then MaxW := 20;
{Готовим память и считываем данные) for k := 0 to 255 do
LengD[k] := 0; (Обнуляем таблицу длин} for k := FirstChar to LastChar do begin
if k=LastChar then
LengD[k] := FileSize-Offsets[k]-FontPara.DataOffset
else
LengD(k] := Offsets[k+1]-Off sets[k];
if LengD[k]<>0 then begin
GetMem(Chars[k],LengD[k]) ;
FontRead(Chars[k]",LengD[k]) end end;
Close(F) ;
end; {with FontData) end; {ReadData} f—————} Procedure BuildScreen;
{Переводит дисплей а графический реяшм, вычисляет константы и создает экран)
procedure PutCur(var Cur: TMouseMask) ;
{Сканирует изображение в левом верхнем углу экрана и формирует маску указателя мыши} var
х,у: Byte;
b: Word;
begin
for у := 0 to 15 do begin b :° 0;
for x := 0 to 15 do
if GetPixel (x, y) OGetBkColor then b := b or ($8000 shr x) ;
Cur[l,y] := b;
Cur[0,y] := not b end end; {PutCLir} {—————} var
D,R,E,k,n,X,Y: Integer;
с: Byte;
S: String;
Sz: Word;
FF: File;
Font: Pointer;
const
Txt: array [1..6] of String [10]=(
•Из таблицы', 'В таблицу', 'Очистить', 'Образец', 'Сохранить', 'Конец');
Items: array [1..6] of MouseItemType=(
(X1:1 ; Y1:1; X2:13; 12:2; Butt: LeftButton; Key 1 ehl 8), (X1:14; Y1:1; X2:25; Y2:2; Butt: LeftButton; Key 2 shi 8), (XI:26; Y1:1; X2:37; Y2:2; Butt: LeEtButton; Key 3 shi 8), (X1:38; Y1:1; X2:49; Y2:2; Butt: LeftButton; Key 4 shi 8), (X1:50; Y1:1; X2:61; Y2:2; Butt: •LeftButton; Key 5 shi 8), (X1:61; Y1:1; X2:80; Y2:2; „Butt: beftButton; Key 6 shi 8));
begin {BuildScreen)
{Переходим в графику}
D := Detect; {Автоопределение драйвера I
InitGraph(D,R,''); (Инициируем графику}
Е :=• GraphResult; {Проверяем результат}
if EoO then
begin {Есть ошибка} WriteLn(GraphErrorMsg(Б));
Halt end;
{Выбираем шрифт а зависимости от разрешения экрана}
case GetMaxY of
199: с := S; {CGA 8х8} 349: с := 14; {EGA 8х14} 479..1024: с := 19; {VGA,SVGA 8х19}
else
с := 8 {Прочие 8х8}
end;
with FontPara do
MaxH := UpperMargin-LowerMargin+1;
{Определяем границы рабочего поля}
DYE = succ(GetMaxY) div (5*MaxH div 4); (Высота клетки}
DXE = succ(GetMaxX) div (2*MaxW); {Ширина клетки}
XE = DXE div 3; (Смещение слева}
YE = 2*с; (Смещение сверху}
ХЕ2 = XE+MaxW*DXE; (Правый нижний угол}
YE2 = YE+MaxH*DYE;
(Определяем размеры указателя мыши в рабочем поле и формируем его маски}
dXm = XE;
dYm = DYE div 3;
(Проверяем наличие мыши}
if not InitMouse then
begin (Нет мыши - завершаем работу} CloseGraph;
WriteLn('Нет мыши - программа не может работать');
Halt end;
(Готовим стандартный указатель}
ShowMouse;
MouseGotoXY(0,0); (В левый верхний угол}
PutCur(CurM); (Получить образ}
HideMouse;
(Указатель-квадратик для рабочего поля}
Rectangle(0,0,2*dXm,2*dXm);
PutCur(CurE); {Подучить образ}
{Расчерчиваем рабочее поле}
ClearWinEd;
fГотовим координаты окна повторения символа} XR :=(XE2-XE) div 2;
YR := GetMaxY-MaxH;
sz := ImageSize(XR,YR,XR+MaxW,YR+MaxH);
GetMem(WR,sz) ;
Getlmage (XR^R^R+MaxW^R+MaxH.WR*);
{Создаем таблицу символов)
XT :- XE+(MaxW+l)*DXE; {Левый верхний} YT :== YE; {угол таблицы символов} DXT := GetMaxX div 32; {Шаг по горизонту} DYT := GetMaxY div 20; {Шаг по вертикали} SetColor(White); /Белый цвет;
for n := 0 to 255 do /'Выводим символы} with FontPara do begin
X :» XT+(n mod 16)*DXT;
Y :" YT+(n div 16)*DYT;
if LengD[n]<>0 then begin
SetColor(White) ;
OutChar(X,Y+DYT,n,DXT/MaxW,DYT/(MaxH+5)) end •Xse
begin [Выводим недостающие символы} SetColor(DarkGray);
OutTextXY(X,Y+DYT-8,Chr(n)) end end;
{Загружаем шрифт из файла SxH.fntf Str(c,S);
S := '8x'+S+'.fnt';
Assign(FF,S) ;
{$!-} Reset (FF,1);
{$!+} if lOResultoO then begin
CloseGraph;
WriteLnCHer шрифтового файла '+S);
Halt end;
Sz := System.FileSize(FF);
GetMem(Font,Sz);
BlockRead(FF,Font",Sz,r) ;
Close(FF) ;
if rOSz then begin
CloseGraph;
WriteLn('Ошибка чтения файла '+S);
Halt end;
{Регистрируем шрифт и переназначаем ввод/вывод} SetFont(Font,8,с) ;
GraphWriteOn;
(Выводим строку меню} ' Colors(Black,LightGray) ;
for k := 1 to 6 do with Items[k] do
SetWindow(XI,Y1,X2,Y2-1,EmptyBorder,Txt[k],False,False,False);
{Инициируем мышь} SetMouseItem(6,Items);
ShowMouse; {Показывав» указатель тшши} TextRatioY := с;
end; (BulldScreen} {—————} Procedure NewFile(var FName: String);
{Создает новый CHR-файл} var
Name: String;
HH: ShortInt;
H,k: Byte;
Y: String [1] ;
const
tl='Максимальная высота символов от базовой линии: ';
t2='Расстояние до нижней кромки символа: ';
13"'Максимальная ширина: ';
t4=" font VI.1 Jan 12, 1989';
t5=#13#10;
t6='Copyright (c) 1987,1988 Borland International';
begin
(Вводим в диалоге параметры шрифта} repeat
Write('Введите 4-буквенное имя шрифта: ':55);
ReadLn(Name);
while Length(Name)<4 do Name := Name+'0';
Name[0] := chr(4) ;
for k := 1 to 4 do
Name[k] := UpCase(Name[k]);
Write(tl:55) ;
ReadLn(H) ;
H :° H and 63;
Write (t2:55) ;
ReadLn(HH) ;
if HH>0 then HH :- -HH;
Write(t3:55) ;
ReadLn(MaxW) ;
MaxW := MaxW and 63;
MaxH := H-HH;
WriteLn;
WriteLn('Будет создан шрифт с именем '+
Name+' со следующими параметрами:');
WriteLn(tl:55,H);
WriteLn(t2:55,HH) ;
WriteLn(t3:55,MaxW) ;
Write('Согласны (Y/N, умлч.У)? ');
ReadLn(У) ;
until (Y<>") or (UpCase(Y[l])<>'N') ;
{Готовим заголовок} for k := 1 to 128 do
FontHead.B[k] := 0;
for k := 1 to 16 do
FontPara.H2[k] := 0;
FName :» Name+'.CHR';
with FontHead do
begin
FontFileID := Head;
Name := 'BGI 4-Name+t4+t5+t6+t5+#0;
for k := 1 to Length(Name) do B[k+4] := ord(Name[k]);
AFileSize :" k+12;
Name := #$80#0+FName;
Name[0] := #$1A; {CopyrightEndl Name[7] := #0; {LolfileSise]} Name[8] := #0; {Hl[FileSizeJ} Name[9] :- *1; {VI.) Name[10] :- #0;
Name[11] := #1; (V.I} for k := 0 to 11 do
B[AFileSi2e-7+k] :- ord(Name[k]) ;
end;
{Готовим Блок параметров} with FontPara do begin
ParPrefix :" '+';
CharsCount :=° 0;
FirstChar :» 0;
DataOffset := 16;
FillFlag := 0;
UpperMargin := H;
LowerMargin := HH end;
{Готовим таблицу длин} for k :- 0 to 255 do LengD[k] := 0;
Assign(F,FName) end;
(—————} begin {Init} repeat
Namelnput(FName); {Вводим и контролируем имя файла} it FNameoI' then
ReadData {Читаеи данные из файла/ else
NewFile(FName) {Создаем новый файл} until FNameo'';
BuildScreen {Создаем экран} end; {Init} /————————————^
Procedure SaveFont;
{Сохраняет шрифт в файле} Procedure Alarm;
{Сообщает об ошибке записи} •чах
X2,Y2,X1,Y1: Integer;
Sz: Word;
P: Pointer;
С: Char;
begin
HideMouse;
Colors(White,Red) ;
Window(15,12,65,14) ;
GetWindGraphCoo(Xl,Yl,X2,Y2) ;
Sz := ImageSize(Xl,Yl,X2,Y2) ;
GetImage(Xl,Yl,X2,Y2,PЛ);
SetWindow(15,12,65,14,2,' Нажмите любую клавишу ',True,True,True);
Write('Ошибка доступа к файлу!':37);
ShowMouse;
while not KeyPressed or not MousePressed do;
while KeyPressed do С := ReadKey;
While MousePressed do;
HideMouse;
PutImagetX^Y^P^NormalPut) ;
ShowMouse;
FreeMem(P,Sz) end; {Alarm} {——————}
Function WriteFile(var Source; S: Word): Boolean;
{Записывает в файл S байт из переменной Source и контролирует результат} var
k: Word;
begin
BlockWrite(F,Source,S,k) ;
WriteFile := S»k;
if Sok then
Alarm end;
/——————;
var
k: Integer;
MinChr,MaxChr: Byte;
W,Offs,PredO: Word;
begin
if not ChangeF then Exit;
{Определяем начальный символ} MinChr := 0;
while (MinChr<255) and (LengD[MinChr]=0) do inc(MinChr) ;
if MinChr=255 then Exit;
(Определяем последний символом} MaxChr := MinChr;
k := MaxChr;
while k<-255 do begin
if LengD[k]<>0 then MaxChr := k;
inc(k) end;
{Корректируем пустые символы к подсчитываем длину загружаемой части} FileSize := 0;
for k := MinChr to MaxChr do if LengD[k]-0 then
begin {Пустой символ) Widths[k] := Widths[MinChr] ;
inc(FileSize,LengD[MinChr]) end else
inc(FileSize,LengD[k]) ;
{Определяем смещение в файле) Offs := 3*(MaxChr-MinChr+l)+16;
(Корректируем описатель шрифта) with FontPara do begin
FirstChar :- MinChr;
CharsCount:» MaxChr-MinChr+1;
Data0ffset:= Offs;
FileSize :» FileSize+16+3*CharsCount end;
{Записываем заголовок} With FontHead do begin
B[AFileSize] :° Lo(FileSize) ;
B[AFileSize+l] :-Hi(FileSize) end;
{Готовим файл} {SI-} Rewrite(F,1) ;
($!+} if IQResultoO then begin Alarm;
Exit end;
if not WriteFile(FontHead,SizeOf(FontHead)) then Exit;
{Записываем описатель)
if not WriteFile(FontPara,SizeOf(FontPara)) then Exit;
{Записываем таблицу смещений) PredO := Offs;
for k :» MinChr to MaxChr do begin
W := Offs-PredO;
if LengD(k]<>0 then
inc(0?fs,LengD[k]) else
inc(Offs,LengD[MinChr]) ;
if not WriteFile(W,2) theo
Exit end;
{Записываем таблицу ширин) for k := MinChr to MaxChr do
if not WriteFile(Widths[k],l) then Exit;
{Записываем данные) for k := MinChr •to MaxChr do if LengD[k]<>0 then
if not WriteFile (Chars [It]*, LengD[k]) then
Exit else else
if not WriteFile(Charstk]",LengD[MinChr]) then Exit;
Close(F); (Все в порядке) ChangeF := False Mid; {SaveFont} ^——————.—————;
Procedure Run;
{Основная работа: чтение мыши или клавиатуры и вызов нужных процедур}
•VAX
BM,XM,YM,B,X,Y: Integer;
x0g,y0g,xlg,ylg: Integer; {Координаты резиновой нити} MPF: Boolean; (Флаг резиновой нити}
PW^AW;
W,op: Word;
Procedure RepChar;
{Повторяет символ в окне повтора} var
k: Word;
begin
{Стираем старое изображение}
PutIniagetXI^YR.WR-^NormalPut) ;
{Формируем новое}
SetWriteMode(NormalPut) ;
SetColor(White) ;
for k := 1 to NVecE do with VecE[k],FontPara do
Line(XR+Xl div DXE,YR+MaxH+LowerMargin-(YB-Y1) div DYE,XR+X2 div DXE, YR+MaxH+LowerMargin-(YB-Y2) div DYE);
end;
{——————}
Function Tabi(var N: Byte): Boolean;
{Выбирает символ из таблицы. Возвращает номер символа или False для правой кнопки} var
X,Y, k,xx,yy,ddx,ddy: Integer;
NX,NY,NXX,NYY: Byte;
Sz: Word;
P: Pointer;
begin
HideMouse;
ddx :" DXT div 2; {Половина ширины}
day :" DYT div 2; {Половина высоты)
X :« XT+ddx; /'Начальный символ)
У :- YT+ddy;
NX :- 0; {Номер столбца)
NY :« 0; {Номер строки)
MouseGotoXy(X,Y) ;
MouseWindow(X,y,X+16*DXT,Y+16*DyT);
{Выделяем символ)
Sz :- ImageSize(X-ddx,Y-ddx,X+ddx,Y+ddx) ;
GetMem(P,sz);
Getlmage(X-ddx,Y-ddy,X+ddx,X+ddy,P*) ;
PutImage(X-ddx,Y-ddy,PA,NotPut) ;
while MousePressed do; ^Сбрасываем кнопку)
{Перемещаемся по таблице до нажатия на кнопку мыши}
while not MousePressed do begin
GetMouseState(k,xx,yy); {Текущее положение} NXX := (xx-XT) div DXT,-NYY := (yy-YI) div DYT;
if (NXONXX) or (NYONYY) then
begin {Перешли в новую клетку} Putlmage(X-ddx,Y-ddy,P",NormalPut) ;
Window(l,l,80,25);
GotoXY(60,25) ;
TextColor(White) ;
TextBackGround(LightRed);
Write(NYY*16+NXX:4,' ');
NX :== NXX;
NY := NYY;
X :» XT+NX*DXT+ddx;
У :« YT+NY*DYT+ddy;
Getlmage(X-ddx,Y-ddy,X+ddx,Y+ddy,P^ ;
Putlmage(X-ddx,Y-ddy,P^,NotPut) ;
end end;
(Нажата кнопка: восстанавливаем экран} Putlmage (X-ddx,Y-ddy,P'',MormalPut);
FreeMem(P,sz);
GotoXY(60,25) ;
Write (' ') ;
GetMouseState(k,xx,yy); {k - нажатая кнопка) while MousePressed do; {Ждем отпускания} N := NY*16+NX;
Tab! := k=LeftButton;
ShowMouse;
MouseScreen (Освобождаем мышь} end; {Tab!} {——————}
Procedure ClearWE;
{Очищает рабочее поле} begin
ClearWinEd;
Putlmage (XR.YI^WR^NormalPut:) ;
NVecE := 0;
WidthX := 0 end;
{——————}
Procedure GetChar;
(Берет символ из таблицы} var
k: Integer;
N: Byte;
W,op: Word;
xx,yy: Shortint;
begin
if not Tab!(N) then
Exit; {Выход по правой кнопке} ClearWE; (Очищаем рабочее поле} PW := Chars[N]; (Адрес описателей} X := 0; (Начальные координаты пера} У := 0;
SetColor(Yellow) ;
SetWriteMode(XORPut) ;
(Цикл по командам} for k := 1 to LengD[N] div 2 do begin
H := PW[k]; (Очередное слово} op := W and $8080; {Код операции} W := W xor op;
xx := W and 127; (Координата Х} yy :=• W shr 8; {Координата Y} if yy>63 then yy := yy-128;
if op=$8080 then
begin (Команда чертить} inc(NVecE); (Колич.векторов} with VecE[NVecE] do
begin (Формируем новый вектор} XI := XE+X*DXE;
Yl :- YB-Y*DYE;
X2 := XE+xx*DXE;
Y2 := YB-yy*DYE;
{Чертим линию в рабочей поле) Line(Xl,Yl,X2,Y2) end;
end;
X := хх; {Новое положение пера) Y :- уу end;
(Чертим правую границу символа} WidthX := XE+Widths[N]*DXE;
SetColor(Cyan) ;
Line(WidthX,YE,WidthX,YE2) ;
{Повторяем символ в окне повтора} RepChar end; {GetChar} {——————}
Procedure SetChar;
{Помещает символ в таблицу} var
k: Integer;
N: Byte;
W,op: Word;
Data: AW;
X,Y,XX1,YY1,XX2,YY2: Shortint;
Xc,Yc: Integers-begin
if not Tabl(N) then Exit;
{Удаляем старый описатель} if LengD[N]<>0 then
FreeMem(Chars[N],LengD[N]);
Widths[N] :«= (WidthX-XE) div DXE;
LengD[N] :" 0;
{Цикл по векторам} X :° 0;
Y :- 0;
for k :- 1 to NVecE do with VecE[k] do begin
XXI := (Xl-XE) div DXE;
XX2 := (X2-XE) div DXE;
YY1 := (YB-Y1) div DYE;
YY2 := (YB-Y2) div DYE;
if (xoxxi) or (YOYYI) then begin {команда перехода} if YYKO then inc(YYl,128) ;
inc(LengD[N]) ;
Data[LengD[N]] :« YYl «Ы 8+ХХ1 or $80 end;
X := XX2;
Y :•= YY2;
if YY2<0 then inc(YY2,128);
inc(LengD[N]) ;
Data[LengD[N]] :- YY2 ahl 8+XX2 or $8080;
end;
{Формируем переход в конец символа} inc (LengD [N]) ;
Data[LengD[N]] :- Widths[N] or $80;
inc(LengD[N]) ;
Data[LengD[N]] :» 0; {Конец команд) {Записываем в память} LengD[N] :-2*LengD[N];
GetMem(Chars[N],LengD[N] ) ;
Move(Data,CharstN]",LengC[N]) ;
{Чертим символ в таблице} HideMouse;
Хс := XT+(N mod 16)*DXT;
Yc := YT+(N div 16)*DYT;
SetFillStyle(SolidFill,Black) ;
Bar(Xc,Yc,Xc+DXT-l,Yc+DYT-l);
SetColor(White) ;
SetWriteMode(NormalPut) ;
OutChar(Xc,Yc+DYT,N,DXT/MaxW,DXT/(MaxH+5)) ;
SetColor(Yellow) ;
SetWriteMode(XORPut) ;
ShowMouse;
ChangeF := True end; {SetChar} {——————}
function Nedfvar x,y: Integer): Boolean;
(Возвращает TRUE и координаты узла, если мышь попала в его окрестности} var
Is: Boolean;
begin
Is := False;
у := YE;
repeat
X := XE;
repeat
Is := MouseIn(x-dXm,y-dYm,x+dXin,y+dYm);
if not Is then
inc(x,DXE) until Is or (x>XE2);
if not Is then
inc(y,DYE) until Is or (y>YE2) ;
Ned := Is end; {Ned} {——————}
Procedure MouseInNed;
{Проверяет отметку мышью узла сетки} var
XM,YN: Integer;
begin
if not Ned(XN,YN) then
Exit; /Яе попали в узел} HideMouse;
while MousePressed do;
MouseGotoXY(XN,YN) ;
if not MPF then
begin /Запоминаем узел} MPF := True;
XOg := XN;
YOg := YN;
Xlg := XOg Ylg :- YOg;
SetColor(Yellow) ;
SetWriteMode(XORPut);
MouseWindow(XE,YE,XE2,YE2) ;
MouseGraphCursor(CurE» dXm,dYm);
ShowMouse and else
begin (Формируем новый вектор! MPF := False;
if (xOgOxlg) or (yOgOylg) then Line(xOg,yOg,xlg,ylg) ;
MouseScreen;
it (XOgoXN) or (YOgoYN) then
begin (Поиещаем очередной вектор} inc(NVecE) ;
with VecE[NVecE] do begin
XI :° XOg;
Yl := YOg;
X2 := XN;
Y2 :- YN;
Lir)e(xl,yl,x2,y2);
RepChar end;
{Проверяем ширину символа^ if XOg>XN then XN := XOg;
if XN>WidthX then
begin {Смещаем правую границу} SetColor(Cyan) ;
SetWriteMode(XORPut) ;
Line(WidthX,YE,WidthX,YE2) ;
WidthX := XN+4*DXE;
if WidthX>XE2 then WidthX := XE2;
Line(WidthX,YE,WidthX,YE2) ;
SetColor(Yellow) ;
end;
MouseGraphCursor(CurM,0,0);
ShowMouse end end
end; {MouseInNed} {——————}
Procedure MouseInLine;
(Проверяет отметку вектора} var
х1т,у1я,х2т,у2т,dx,dy,x,y,n: Integer;
Is,Sign: Boolean;
k: Word;
k0,y0: Real;
label Loop;
begin
if MPF then
begin {Уничтожаем резиновую нить} HideMouse;
MPF := False;
if (XOgoXlg) or (YOgoYlg) then Line(XOg,YOg,Xlg,Ylg) ;
MouseGraphCursor(CurM,0,0);
ShowMouse;
MouseScreen;
Exit end;
if NVecE-0 then
Exit; {Пустое рабочее поле} Loop:
GetMouseState(x,xlm,ylm) ;
if (not MousePressed) and MouseF then begin
HideMouse;
MouseGraphCursor(CurM,0,0);
ShowMouse;
MouseScreen;
MouseF :" False;
Exit end;
x2m := xlm+dXm;
y2m := ylm+dYm;
xlm := xlm-dXm;
ylm := ylm-dYm;
{Проверяем все векторы} n := 1;
Is :a= False;
repeat
with VecE[n] do if (xl=x2) and (xl>=xlm) and (xl<=x2m) then {Вертикальный вектор}
Is := ((yl>=y2m) and (y2<=ylm)) or ((yl<=ylm) and (y2>=y2m)) else if (yl=y2) and (yl>=ylm) and (yl<=y2m) -then (Горизонтальный вектор}
Is := ((xl>=xlm) and (x2<=x2m)) or ( (xl<=x2m) and (x2>»-xlm)) else {Наклонный вектор} if (((yl>=y2m) and (y2<=ylm)) or ((yl<=ylm) and (y2>=y2m))) and (((xl>=xlm) and (x2<»St2m)) or ((xl<=x2m) and (x2>=xlm))) then begin
kO := (y2-yl)/(x2-xl);
yO := yl-k0*xl;
for x := xlm to x2m do if not Is then begin
у := Round(k0*x+y0) ;
Is := (y>=ylm) and (y<»y2m) ;
if not Is then if x=xlm then
Sign := y<ylm else
Is:= (Sign and (y>ylm)) or (not Sign and (y<ylm)) end end;
if not Is then
inc(n) until Is or (n>NVecE) ;
if Is then
begin {Удаляем вектор! HideMouse;
SetColor(Yellow) ;
SetHriteMode(XORPut) ;
with VecE[N) do
Line(xl,yl,x2,y2); /Стираем линию}
if NVecE>l then {Перемещаем векторы} for N :- N to NVecE-1 do VecE[N] := VecEtN+1];
dec(NVecE) ;
RepChar;
it NVecE>l then begin
MouseGraphCursor(CurE,dXm,dYm);
MouseWindow(XE-dXm,YE-dYm,XE2+dXm,YE2+dYm) ;
MouseF :° True end else begin
MouseGraphCursor(CurM,0,0);
MouseScreen;
MouseF := False end;
ShowMouse;
it MouseF then
Goto Loop end else if MouseF then
Goto Loop els» if (WidthX>-xlm) and (WidthX<"x2m) then
begin {Перемещаем правую границу} SetColor(Cyan) ;
SetWriteMode(XORPut);
HideMouse;
MouseGraphCursor(CurE,dXm,dYm);
ShowMouse;
MouseWindow(XE,YE,XE2,YE2) ;
while MousePressed do begin
GetMouseStste(n,xlm,ylm);
if XE+DXE*Round((xlm-XE)/DXE)<>WidtbX then begin
HideMouse;
Line(WidthX,YE,WidthX,YE2) ;
WidthX := XE+DXE*Round((xlm-XE)/DXE) ;
Line(WidthX,YE,WidthX,YE2) ;
ShowMouse end end;
MouseScreen;
HideMouse;
MouseGraphCursor(CurM,Q, 0) ;
ShowMouse and end;
{——————}
Procedure MouseMove;
{Контролирует перемещение мыши} begin
if MPF and ( (XMoXlg) or (YMOYlg)) then
begin {Формируем резиновую нить) HideMouse;
if (XOgOXlg) or (YOgOYlg) then
Line(XOg,YOg,Xlg,Ylg); {Стираем старую}
Xlg := XM; (Новые координаты конца}
Ylg := YM;
if (XOgoXlg) or (YOgOYlg) then Line (XOg,YOg,Xlg, Ylg) ;
ShowMouse end;
end; {MouseMove} {——————}
Procedure Pattern;
{Выбирает и помещает в рабочее поле образец} var X,Y,xx,yy: Integer;
k,op,W: Word;
PW^AW;
N: Byte;
begin
if not Tabi(N) than
Exit; (Выход по правой кнопке} SetColor(LightGray) ;
PW := Chars[N]; {Адрес описателей} X := XE; (Начальные координаты пера} У := YB;
{Цикл по командам} for k := 1 to LengD[N] div 2 do begin
H := PW^I-k]; (Очередное слово} ор := H and $8080; (Код операции) W := W acor op;
xx := W and 127; {Координата Х} yy := W shr 8y {Координата Y) if yy>63 then УУ ••= УУ-128;
xx :- XE+xx*DXE;
yy := YB-yy*DYE;
if op-$8080 then Line (X, У, xoc, yy) ;
X := xx; {Новое положение пера} Y := yy end;
SetColor(Yellow) end;
/—————;
begin {Run}
SetWriteMode(XORPut) ;
NVecE :•= 0; (Нет векторов в WE} MPF := False; {Мышь не нажималась} SetColor(Yellow) ;
GetMouseState(BM,XM,YM); (Начальное состояние ыыши} While True do /Бесконечный цикл до команды "Конец" } begin
{Проверяем выбор меню и клавиатуру} if KeyOrMousePressed then case ReadKeyOrMouse of
#0: case ReadKeyOrMouse of
#1 GetChar;
#2 SetChar;
#3 ClearWE;
#4 Pattern;
#5 Savefont;
#6 Exit;
end;
end;
{Проверяем текущее состояние мыши} GetMouseState(В,X,Y) ;
if (BOBM) or (XOXM) or (YOYM) then if MousePressed and
MouseIn(XE,YE,XE2,YE2) then
case В of {Контролируем кнопки} LeftButton :MouseInNed;
RightButton:MouseInLine;
end
else {Контролируем перемещение} MouseMove;
XM :» X;
YM := Y;
BM := В end end; {Run}
Procedure Done;
begin
SaveFont;
CloseGraph;
end; (Done} _•-————————————;
begin {Главная программа}
Init; {Инициация шрифта и экрана}
Run; {Редактирование или создание символов}
Done (Завершение работы}
end.
