GEM-Fonts in OMIKRON.BASIC
Vollkommen fasziniert und geblendet von den MAC-Möglichkeiten, mit verschiedenen Fonts die Programme zu verschönern, setzte ich es mir in den Kopf, gleiches auch für den ST zu ermöglichen. Da kam der Artikel in der ST-Computer 4/88 gerade recht - nur leider war alles für ST-Pascal konzipiert... Und da ich begeisterter OMIKRON.BASIC-Programmierer bin, machte ich mich daran diese Möglichkeiten auch für den ST-BASIC-Programmierer zu verwirklichen.
Es war ein steiniger Weg, bevor die ersten USZ (unbekannte Schriftzeichen) auf dem Bildschirm auftauchten, und mich damit in Entzücken versetzten, denn die Dokumentationen schweigen sich natürlich immer genau über die Punkte beharrlich aus, die die meisten Schwierigkeiten bereiten (s.a. Murphy’s Gesetze).
Ich habe versucht, das Programm möglichst gut zu kommentieren. Es ist jedem zu raten, daß er sich ein ähnliches Format für Prozedur- und Funktionsköpfe angewöhnt, denn Fehler, die auftreten, weil man im Hauptprogramm eine Variable benutzt, die in einem Unterprogramm nicht lokal ist, sind nur seeeehr schwer zu finden...
Die Gemfont-Library besteht aus folgenden Prozeduren und Funktionen:
- FN Install_Fonts installiert Zeichensätze mit einer ID
- FN Unload_Fonts entfernt Zeichensatzgruppe
- FN Install_Font installiert einen Zeichensatz
- FN Unload_Font löscht den letzten Zeichensatz
- FN Swap_Word vertauscht High- und Low-Byte
- First_Font gibt Zeiger auf Systemfont-Header zurück; entweder auf alle drei im ROM oder auf den Shadow des 8x16 im RAM
- FNLast_Font gibt Zeiger auf letzten Font zurück
Eine nicht weniger nützliche Funktion (besonders bei der Entwicklung) ist F_Header, womit man sich die Daten des Font-Headers an Adresse() ausgeben lassen kann.
Weiter sind im Programm noch einige Prozeduren zu finden, die mit der Gemfont-Library nichts zu tun haben, aber die Programmierung des Demo-Programms erleichtert haben (näheres im Listing).
Wie die Funktionen praktisch angewendet werden, zeigt das Demoprogramm sehr ausführlich. Man sollte es vermeiden, nach den Zeichensätzen noch andere Speicherblöcke anzulegen, wenn man die Zeichensätze löschen will, denn FRE gibt nur den zuletzt angelegten Speicherblock wirklich frei, die anderen erst, wenn auch die nachfolgenden gelöscht sind.
Leider ist es mir auch noch nicht gelungen herauszufinden, wie man Fonts im 8088-Format von solchen im 68000-Format unterscheidet. Das korrespondierende Bit im Fontheader ist nämlich bei den mir vorliegenden 8088-Fonts nicht korrekt gelöscht. Für Tips wäre ich da sehr dankbar.
Einige Tips zu OMIKRON.BASIC
- ein “Subscript out of Range” der auf WEND zeigt, bezieht sich auf eine Indizierung bei While...
- der Gebrauch von Funktionen ist sehr zu empfehlen, da man aus ihnen ohne großen Aufwand mit einem Wert aussteigen kann! (siehe dazu z.B. die diversen Fehlerabfragen der Install-Funktionen)
- wenn OMIKRON.BASIC bzw. der ST im GEM abstürzt - z.B. wegen fehlerhafter Fontheader - dann ist er wirklich weg vom Fenster und auch eine resetfeste RAM-Disk hat nicht die geringste Chance. Es hilft also nur, ganz neu zu starten...
- SORT(0) ruft (bei mir) recht komische Ergebnisse hervor, z.B. werden einfach die letzten Feldinhalte gelöscht??? So ein Fehler ist natürlich schwer zu finden.
- um für die ‘normalen’ Ausgabebefehle einen neuen Font zu installieren, muß man die Adresse des Fonts in LPEEK(SEGPTR-8) schreiben. Es ist aber zu beachten, daß der Font die An forderungen an einen Systemfont erfüllt, als da sind:
Größe ist 8x16
alle Zeichen gleiche Breite (momospaced)
alle Zeichen müssen vorhanden sein (ade_low=0, ade_high=255)
So, das soll es zu dieser Library gewesen sein. Ich hoffe, daß das Ergebnis eine Augenweide für jeden ist.
LIBRARY Gem,"Gem.lib" ' Hier Pfad für GEM-Lib
CEAR: Appl_Init
V_Opnvwk
Vs_Clip (0,0, 640,400)
Abc1$="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Anc2$="abcdefghijklmnopqrstuvwxyz 1234567890 ! $%&/()=?P'#A+*,;.
Pfad$="A:\*.FNT"
Name$=" "
REPEAT
MOUSEON
FORM_ALERT (2,"[1][ Welche Demo | soil's denn sein? ][ Font | Fonts ]", Entscheidung%L)
MOUSEOFF
IF Entscheidung%L=1 THEN
Fileselec Font_Name$,Pfad$,Name$,"Font auswählen"
MOUSEON
FORM_ALERT (2,"[2][ In welchem Format | liegt der Font vor? ][ 8088 | 68000 ]",Ibm%L)
MOUSEOFF
Ibm%L=Ibm%L-2
R%L=FN Install_Font%L(Font_Name$,Ibm%L)
IF R%L>0 THEN
N$=""
FOR I%L=$4 TO $23
N$=N$+ CHR$( PEEK(R%L+I%L))
NEXT I%L
Nr%L= WPEEK(R%L)
P%L= WPEEK(R%L+2)
ELSE
IF R%L=0 THEN
Fehler$="Font nicht gefunden"
ELSE
Fehler$="nicht genug Speicher"
ENDIF
PRINT Fehler$
REPEAT UNTIL INKEY$ <>""
GOTO Ende
ENDIF
F_Header(R%L)
REPEAT UNTIL INKEY$ <>""
CLS
K%L=0
RESTORE Effects
Vst_Font(Nr%L)
Vst_Point(P%L)
Y%L=0
FOR I%L=0 TO 5
READ K%L
Vst_Effects(K%L)
Y%L=Y%L+P%L+10
V_Gtext(5,Y%L, LEFT$(N$,14)+Abc1$)
Y%L=Y%L+P%L+7
V_Gtext(5,Y%L,Abc2$)
NEXT I%L
-Ende
REPEAT UNTIL FN Unload_Font%L=0
ELSE
CLS
INPUT "Bitte geben sie den Fontnamen ein: ";Nam$
MOUSEON
FORM_ALERT (2,"[2][ In welchem Format | liegt der Font vor? ][ 8088 | 68000 ]",Ibm%L)
MOUSEOFF
Ibm%L=Ibm%L-2
Ptr%L=FN Install_Fonts%L("a:\",Nam$,Ibm%L)
IF Ptr%L<1 THEN
IF Ptr%L=0 THEN Fehler$="gewünschte Fonts nicht gefunden"
IF Ptr%L=-1 THEN Fehler$="gewünschte Größen nicht vorhanden"
IF Ptr%L=-2 THEN Fehler$="nicht genug Speicher"
PRINT Fehler$
REPEAT UNTIL INKEY$ <>""
GOTO Schluss
ENDIF
Vst_Font( WPEEK(Ptr%L))
Y%L=0
CLS
FOR I%L=0 TO F_Nr%L
Points%L= VAL(F_Name$(I%L))
Vst_Point(Points%L)
Y%L=Y%L+Points%L
V_Gtext(10,Y%L,Name$+F_Name$(I%L)+" " +Abc1$)
Y%L=Y%L+Points%L
V_Gtext(10,Y%L,Abc2$)
NEXT I%L
-Schluss
A%L=FN Unload_Fonts%L( WPEEK(Ptr%L))
ENDIF
Vst_Font(1):Vst_Point(8):Vst_Rotation(0):Vst_Effects(0)
V_Gtext(560,397," c für Ende ")
IF LOWER$( INPUT$(1))="C" THEN EXIT
UNTIL 0
Vst_Point(12)
V_Clsvwk
Appl_Exit
END
-Effects
DATA 0,1,2,4,8,16,32
'
-Error
IF ERR =7 THEN M_Error%L=-1 ' bei 'Out of memory' -1 zurückgeben
RESUME NEXT
'
'###########################################
'### Font Library ###
'### Version 2.1, 25.4.1989 ###
’### ###
'### copyright 1989 by Uwe Koloska ###
'### Bundeshöhe 7 ###
'### 5600 Wuppertal 2 ###
'### ###
'###########################################
'*******************************************
'*** FN Install_Fonts ***
'*******************************************
'
' installiert Zeichensätze
' um eine effektive Ausnutzung des Speichers
' zu gewährleisten (nur einmal
' Speicher reservieren für alle Fonts),
' ist diese Routine unabhängig von
' INSTALL_FONT programmiert!!!
'
'VARIABLEN++++++++++++++++++++++++++++++++++++
' Pfad$ NUR Pfad unter dem Fonts zu finden sind (z.B.: "A:\"
' Name$ gemeinsamer Name der Fonts (z.B.: "Swiss")
' Es MUSS der vollständige Name angegeben werden!!!
' Geladen wird sonst auch - aber nicht richtig nach der Größe sortiert
' könnte über zusätzliche Sicherheitsabfrage abgefangen werden;
' was m.E.nicht notwendig ist!
' Ibm_Flag%L Word-Format von Header und Offset-Tabellen
' Wahl$ In diesem String kann eine Auswahl nach Größen
' getroffen werden.
' Format: "<Zahl>asc,(<Zahl>asc...)"
' Zahl muß eine zweistellige Zahl sein (s.f_name$(), der
' ein beliebiges ASCII-Zeichen folgt.
' - dies nur zur besseren Lesbarkeit!!!
' Beispiel: Wahl$="22,30"
' => nur Fonts Gr. 22 und 30
' soll Wahl$ nicht beachtet werden, einfach "" übergeben
' f_max%L L max. Fontanzahl (wird nach Bedarf auch vergrößert)
' F_Name$() Ergänzung des Fontnamens ohne Pfad und Extension
' z.B.: [Swiss] nur "72" - Rest wird entfernt damit
' n.Fontgröße sortiert werden kann
' Funktion kann nur sinnvoll arbeiten, wenn die Größen
' zweistellig hinter dem Fontnamen stehen - also
' "Swiss07" und nicht "Swiss7" -
' da nach ASCII sortiert wird (z.B.: "100"<"2")
' F_Len%L() Länge des Fonts
' die beiden letzten Variablen sind GLOBAL
' und zwar ist darin bis zum Index F_Nr%L eine Liste der
' geladenen Größen und der Längen
' so weiß man direkt die vorhandenen GröPen und kann über
' die File-Längen direkt auf die Font-Header zugreifen
' F_Nr%L L Laufvariable (WHILE..WEND)
' Fonts_Len%L L gesamte Länge aller Fontdaten (Summe über F_Len())
'
' F_Name$ B sinnvoller Ausschnitt aus dem Namen (nur Länge + Ext.)
' Len$ B Länge (nur am Anfang verwendet)
' beide Variablen müssen sein, da sie nur innerhalb von
' OPEN "U" und CLOSE definiert sind
' sie weisen also eigentlich nur bestimmten Ausschnitten
' des Buffers einen Namen zu
'
' Fonts_Ptr%L RL Adresse des ersten (kleinsten) geladenen Fonts
' F_Ptr%L L Adresse des akt. Fonts
' Ptr%L L Adresse des letzten eingeladenen Fonts
' I%L L Laufvariable (FOR..NEXT)
' Wahl%L L Zeiger in den Wahl$
' Fonts%L L Zeiger in die Fontliste
' Font_Z%L L Zähler für die gewünschten und auch verfügbaren Fonts
' zeigt an, wieviel Fonts geladen wurden
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ERGEBNIS Zeiger auf den ersten (kleinsten) geladenen Font
' s. auch Fonts_Ptr%L oder Fehlercode
' 0 => keine Fonts mit diesem Namen vorhanden
' -1 => nicht die gewünschten Fonts vorhanden '
' ROUTINEN+++++++++++++++++++++++++++++++++++++++++++++++++++++++
' FN Swap_Word(W) High- und Low-Byte eines Words vertauschen
' (8088 <> 86000)
' First_Font(Ptr) Zeiger auf den Systemfontheader
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
DEF FN Install_Fonts%L(Pfad$,Name$,Ibm%L)=FN Install_Fonts%L(Pfad$,Name$,Ibm%L,"")
'
DEF FN Install_Fonts%L(Pfad$,Name$,Ibm%L,Wahl$)
LOCAL F_Max%L=6,Fonts_Len%L,F_Name$,Len$,Fonts_Ptr%L
LOCAL I%L,F_Ptr%L,Ptr%L,Fonts%L,Wahl%L,Font_Z%L
F_Nr%L=0
'
DIM F_Name$(F_Max%L),F_Len%L(F_Max%L)
'
OPEN "F",2,Pfad$+Name$+"*.FNT",0 ' Fontgrößen und Filelängen erfragen
GET 2,1
WHILE NOT EOF(2)
IF F_Nr%L>=F_Max%L THEN DIM F_Name$(F_Nr%L),F_Len%L(F_Nr%L)
FIELD 2,26,4 AS Len$, LEN(Name$),14-LEN(Name$) AS F_Name$
F_Name$(F_Nr%L)= LEFT$(F_Name$,INSTR(F_Name$,".")-1)
F_Len%L(F_Nr%L)= CVIL(Len$)
Fonts_Len%L=Fonts_Len%L+F_Len%L(F_Nr%L)
F_Nr%L=F_Nr%L+1
GET 2,1
WEND
CLOSE 2
'
IF F_Nr%L=0 THEN RETURN 0 'kein Font dieses Namens vorhanden
'
SORT F_Name$(F_Nr%L-1) TO F_Len%L(F_Nr%L-1)
' VORSICHT!!! bei Indizierung mit 0 'SORT feld(0)' passieren arg
' komische Dinge z.B. werden d.letzten Elemente einfach gelöscht (???)
'
IF Wahl$<>"" THEN ' Wahl$ auswerten
Fonts_Len%L=0
FOR Wahl%L=1 TO LEN(Wahl$) STEP 3
WHILE VAL( MID$(Wahl$,Wahl%L,2))>=VAL(F_Name$(Fonts%L)) AND Fonts%<>F_Nr%L
IF VAL( MID$(Wahl$,Wahl%L,2))=VAL(F_Name$(Fonts%L)) THEN
F_Name$(Font_Z%L)=F_Name$(Fonts%L)
F_Len%L(Font_Z%L)=F_Len%L(Fonts%L)
Fonts_Len%L=Fonts_Len%L+F_Len%L(Font_Z%L)
Font_Z%L=Font_Z%L+1
ENDIF
Fonts%L=Fonts%L+1
WEND
NEXT Wahl%L
F_Nr%L=Font_Z%L
ENDIF
F_Nr%L=F_Nr%L-1
IF F_Nr%L=-1 THEN RETURN -1 ' keiner der gewünschten Fonts vorhanden
'
M_Error%L=0
Fonts_Ptr%L= MEMORY(Fonts_Len%L+50) ' alle Fonts bekommen einen Speicherblock
IF M_Error%L THEN RETURN -2 ' nicht genug Speicher
F_Ptr%L=Fonts_Ptr%L
'
FOR I%L=0 TO F_Nr%L
'
BLOAD Pfad$+Name$+F_Name$(I%L)+".FNT",F_Ptr%L
'
IF Ibm_Flag%L THEN ' 8086- in 68000er-Format
WPOKE F_Ptr%L,FN Swap_Word%L( WPEEK(F_Ptr%L))
WPOKE F_Ptr%L+2,FN Swap_Word%L( WPEEK(F_Ptr%L+2))
FOR I%L=$24 TO $42 STEP 2
WPOKE F_Ptr%L+I%L,FN Swap_Word%L( WPEEK(F_Ptr%L+I%L))
NEXT I%L
LPOKE F_Ptr%L+$44,FN Swap_Word%L( WPEEK(F_Ptr%L+$44))
LPOKE F_Ptr%L+$48,FN Swap_Word%L( WPEEK(F_Ptr%L+$48))
LPOKE F_Ptr%L+$4C,FN Swap_Word%L( WPEEK(F_Ptr%L+$4C))
WPOKE F_Ptr%L+$50,FN Swap_Word%L( WPEEK(F_Ptr%L+$50))
WPOKE F_Ptr%L+$52,FN Swap_Word%L( WPEEK(F_Ptr%L+$52))
' Korrigieren der Character-Offsets
Start%L= LPEEK(F_Ptr%L+$48)
FOR I%L=Start%L TO Start%L+( WPEEK(F_Ptr%L+$26)-WPEEK(F_Ptr%L+$24)+1)*2 STEP 2
WPOKE F_Ptr%L+I%L,FN Swap_Word%L( WPEEK(F_Ptr%L+I%L))
NEXT I%L
'
IF BIT (1, WPEEK(F_Ptr%L+$42)) THEN
' wenn Horizontal-Offset dann
Start%L= LPEEK(F_Ptr%L+$44)
' Korrigieren der Horizontal-Offsets
FOR I%L=Start%L TO Start%L+( WPEEK(F_Ptr%L+$26)-WPEEK(F_Ptr%L+$24))*2 STEP 2
WPOKE F_Ptr%L+I%L,FN Swap_Word%L( WPEEK(F_Ptr%L+I%L))
NEXT I%L
ENDIF
ENDIF
'
LPOKE F_Ptr%L+$44,F_Ptr%L+LPEEK(F_Ptr%L+$44) ' hz_ofst
LPOKE F_Ptr%L+$48,F_Ptr%L+LPEEK(F_Ptr%L+$48) ' ch_ofst
LPOKE F_Ptr%L+$4C,F_Ptr%L+LPEEK(F_Ptr%L+$4C) ' fnt_dta
LPOKE F_Ptr%L+$54,F_Ptr%L+F_Len%L(I%L)+2
Ptr%L=F_Ptr%L
F_Ptr%L=F_Ptr%L+F_Len%L(I%L)+2 ' muß sein, sonst zerfleischen sich die Daten
'
NEXT I%L
LPOKE Ptr%L+$54,0
Ptr%L=FN Last_Font%L
LPOKE Ptr%L+$54,Fonts_Ptr%L ' einhängen in Font-Liste
RETURN Fonts_Ptr%L
'
'****************************************************************
'*** FN Unload_Fonts ***
'****************************************************************
'
' löscht die letzten Fonts mit der Face-ID Id oder die letzte Fontgruppe
' weil FRE(adr) nur den letzten angelegten Speicherblock löschen kann, ist es
' auch nur sinnvoll die letzten Fonts zu löschen
' mit INSTALL_FONTS geladene Fonts könne nur mit dieser Funktion glöscht werden
' (weil sie nur einen Speicherblock insgesamt belegen)
'
' VARIABLEN++++++++++++++++++++++++++++++++++++++++++++++++++++++
' Id%L Face ID der zu löschenden Fonts
' F1_Ptr%L L Zeiger auf Vorgänger
' F2_Ptr%L L Zeiger auf zu löschenden Font
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ERGEBNIS 0 => Fehler - letzter Font hat andere ID
' oder ist System-Font
' -1 => alles Roger
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'
' ROUTINEN+++++++++++++++++++++++++++++++++++++++++++++++++++++++
' First_Font(Ptr) Zeiger auf Systemfontheader
' FN Last_Font ergibt Zeiger auf letzten Font der Liste
' ruft FN First_Font auf
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'
DEF FN Unload_Fonts%L
LOCAL Id%L= WPEEK(FN Last_Font%L)
RETURN FN Unload_Fonts%L(Id%L)
'
DEF FN Unload_Fonts%L(Id%L)
LOCAL F1_Ptr%L,F2_Ptr%L
'
First_Font(F2_Ptr%L)
F1_Ptr%L=FN Last_Font%L
IF WPEEK(F1_Ptr%L)Old%L THEN RETURN 0 ' letzter Font hat andere ID
' (kann auch Systemfont sein)
REPEAT
F1_Ptr%L=F2_Ptr%L ' Zeiger auf Vorgänger
F2_Ptr%L= LPEEK(F2_Ptr%L+$54)
UNTIL WPEEK(F2_Ptr%L)=Id%L
FRE (F2_Ptr%L)
LPOKE F1_Ptr%L+$54,0 ' Zeichensatzkette Ende
RETURN -1
'
'****************************************************************
'*** FN Install_Font ***
'****************************************************************
'
' installiert Zeichensatz
' um verschiedene Größen eines Fonts zu laden, bediene man sich tunlichst der
' Funktion INSTALL_FONTS, da Gern die Fonts mit einer Face-ID in aufsteigender
' Reihenfolge erwartet - beim ersten Font mit anderer Face-ID wird die Suche
' nach der passenden GröPe (vst_point) abgebrochen
'
'VARIABLEN+++++++++++++++++++++++++++++++++++++++++++++++++++++++
' Pfad$ vollständiger Pfad mit dem Zeichensatznamen
' Ibm_Flag%L Word-Format von Headers und Offset-Tabellen
' 0 => 68000 Format
' 1 => 8086 Format
' Flang%L L Filelänge des Zeichensatzes
' Ptr%L L Zeiger a. letzten Zeichensatz
' F_Ptr%L RL Zeiger a. gelad. Zeichensatz
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ERGEBNIS Adresse des Fonts oder
' 0 => Font nicht gefunden
' -1 => zuwenig Speicher
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'
' ROUTINEN+++++++++++++++++++++++++++++++++++++++++++++++++++++++
' FN Swap_Word(W) High- und Low-Byte eines Words vertauschen
' (8088 <> 86000)
' FN Last_Font ergibt Zeiger auf letzten Font der Liste
' ruft FN First_Font auf
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
DEF FN Install_Font%L(Pfad$,Ibm_Flag%L)
LOCAL Flang%L,F_Ptr%L,Ptr%L
'
OPEN "F",2,Pfad$,0
GET 2,1
IF EOF(2) THEN
CLOSE 2
RETURN 0
ENDIF
FIELD 2,26,4 AS Len$
Flang%L= CVIL(Len$)
CLOSE 2
'
M_Error%L=0
F_Ptr%L= MEMORY(Flang%L)
IF M_Error%L THEN RETURN -1 ' zu wenig Speicherplatz
BLOAD Pfad$,F_Ptr%L ' 8086- in 68000'er-Format
IF Ibm_Flag%L THEN
WPOKE F_Ptr%L,FN Swap_Word%L( WPEEK(F_Ptr%L))
WPOKE F_Ptr%L+2,FN Swap_Word%L( WPEEK(F_Ptr%L+2))
FOR I%L=$24 TO $42 STEP 2
WPOKE F_Ptr%L+I%L,FN Swap_Word%L( WPEEK(F_Ptr%L+I%L))
NEXT I%L
LPOKE F_Ptr%L+$44,FN Swap_Word%L( WPEEK(F_Ptr%L+$44))
LPOKE F_Ptr%L+$48,FN Swap_Word%L( WPEEK(F_Ptr%L+$48))
LPOKE F_Ptr%L+$4C,FN Swap_Word%L( WPEEK(F_Ptr%L+$4C))
WPOKE F_Ptr%L+$50,FN Swap_Word%L( WPEEK(F_Ptr%L+$50))
WPOKE F_Ptr%L+$52,FN Swap_Word%L( WPEEK(F_Ptr%L+$52))
' Korrigieren der Character-Offsets
Start%L= LPEEK(F_Ptr%L+$48)
FOR I%L=Start%L TO Start%L+( WPEEK(F_Ptr%L+$26)-WPEEK(F_Ptr%L+$24)+1)*2 STEP 2
WPOKE F_Ptr%L+I%L,FN Swap_Word%L( WPEEK(F_Ptr%L+I%L))
NEXT I%L
'
IF BIT(1, WPEEK(F_Ptr%L+$42)) THEN
' wenn Horizontal-Offset dann
Start%L= LPEEK(F_Ptr%L+$44)
' Korrigieren der Horizontal-Offsets
FOR I%L=Start%L TO Start%L+( WPEEK(F_Ptr%L+$26)-WPEEK(F_Ptr%L+$24))*2 STEP 2
WPOKE F_Ptr%L+I%L,FN Swap_Word%L( WPEEK(F_Ptr%L+I%L))
NEXT I%L
ENDIF
'
ENDIF
' Zeiger auf absolute Adressen
LPOKE F_Ptr%L+$44,F_Ptr%L+LPEEK(F_Ptr%L+$44) ' hz_ofst
LPOKE F_Ptr%L+$48,F_Ptr%L+LPEEK(F_Ptr%L+$48) ' ch_ofst
LPOKE F_Ptr%L+$4C,F_Ptr%L+LPEEK(F_Ptr%L+$4C) ' fnt_dta
Ptr%L=FN Last_Font%L
LPOKE Ptr%L+$54,F_Ptr%L ' einhängen in Font-Liste
LPOKE F_Ptr%L+$54,0
RETURN F_Ptr%L
'****************************************************************
'*** FN Swap_Word ***
'****************************************************************
'
' High- und Low-Byte vertauschen
'
' VARIABLEN++++++++++++++++++++++++++++++++++++++++++++++++++++++
' W%L Word dessen Bytes getauscht werdensollen
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ERGEBNIS Word mit vertauschtem High- und Low-Byte
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'
DEF FN Swap_Word%L(W%L)=(W%L AND 65280) SHR 8 OR (W%L AND 255) SHL 8
'
'****************************************************************
'*** FN Unload_Font ***
'****************************************************************
'
' löscht den jeweils letzten Zeichensatz
' weil FRE(adr) nur den jeweils letzten angelegten Block auch wirklich löschen
' kann, ist es nur sinnvoll die Liste von hinten aufzurollen
'
' VARIABLEN++++++++++++++++++++++++++++++++++++++++++++++++++++++
' F1_Ptr%L L Zeiger a.vorletzten Zeichensatz
' F2_Ptr%L L Zeiger auf letzten (d.h. zu löschenden) Zeichensatz
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ERGEBNIS 0 => kein Zeichensatz mehr geladen
' -1 => alles Roger
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
DEF FN Unload_Font%L
LOCAL F1_Ptr%L,F2_Ptr%L
'
First_Font(F1_Ptr%L)
IF LPEEK(F1_Ptr%L+$54)=0 THEN RETURN 0
F2_Ptr%L=FN Last_Font%L
'
WHILE LPEEK(F1_Ptr%L+$54)<>F2_Ptr%L
F1_Ptr%L= LPEEK(F1_Ptr%L+$54) ' Zeiger auf Vorgänger
WEND
'
FRE (F2_Ptr%L)
LPOKE F1_Ptr%L+$54,0 ' Zeichensatzkette Ende
RETURN -1
'
'****************************************************************
'*** First_Font ***
'*** Original von LPSoft 1987 ***
'*** Umsetzung und Erweiterung f.OMIKRON ***
'*** Uwe Koloska August 1988 ***
'****************************************************************
'
' Maschinenspracheprogramm, das die Adressen der Systemfontheader
' zurückgibt
'
' VARIABLEN++++++++++++++++++++++++++++++++++++++++++++++++++++++
' Fflag% Flag, ob Maschinenspracheprogramm initialisiert wurde
' Code%L Adresse des Maschinenprogramms
' Addr%L Adresse des Systemfontvektors
' F1%L,F2%L,F3%L R Adressen der drei Systemfontheader (6x6, 8x8, 8x16)
' F%L R Adresse des ersten Fonts im RAM (Shadow von 8x16)
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' CODE+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' start: movem.l d0/a0-a2,-(a7)
' dc.w $A000
' movea.l 4(a1),a1
' lea reg(pc),a0
' move.l a1,(a0)
' movem.l (a7)+,d0/a0-a2
' rts
' nop
' reg: ds.l 1
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
IF TIMER THEN
DEF PROC First_Font(R F%L)
ELSE
DEF PROC First_Font(R F1%L,R F2%L,R F3%L)
ENDIF
IF Fflag%=0 THEN
Code%L= MEMORY(24)
IF Code%L\2<>Code%L/2 THEN Code%L=Code%L+1
WPOKE Code%L,$48E7: WPOKE Code%L+2,$80E0 ' Maschinenprogramm
WPOKE Code%L+4,$A000: WPOKE Code%L+6,$41FA
WPOKE Code%L+8,$C: WPOKE Code%L+10,$2089
WPOKE Code%L+12,$4CDF: WPOKE Code%L+14,$701
WPOKE Code%L+16,$4E75: WPOKE Code%L+18,$4E71
Fflag%=l ' ist initalisiert
ENDIF
XBIOS (,38,L Code%L) ' Supervisoraufruf
Addr%L= LPEEK(Code%L+20)
F1%L= LPEEK(Addr%L)
F2%L= LPEEK(Addr%L+4)
F3%L= LPEEK(Addr%L+8)
F%L= LPEEK(F2%L+$54)
RETURN
'
'
'****************************************************************
'*** Last_Font ***
'****************************************************************
'
' gibt Zeiger auf letzten Zeichensatz zurück
'
' VARIABLEN++++++++++++++++++++++++++++++++++++++++++++++++++++++
' F_Ptr%L RL Zeiger auf letzten Zeichensatz
'ROUTINEN++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' First_Font(zeiger) gibt Zeiger auf 8x16-System-Font zurück
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
DEF FN Last_Font%L
LOCAL F_Ptr%L
First_Font(F_Ptr%L)
WHILE LPEEK(F_Ptr%L+$54)<>0
F_Ptr%L= LPEEK(F_Ptr%L+$54)
WEND
RETURN F_Ptr%L
'################################################################
'
'
'****************************************************************
'*** Fileselec ***
'****************************************************************
'
' stellt eine Filesectorbox dar und gibt entweder den vollständigen
' Filenamen oder bei 'ABBRUCH' einen Leerstring zurück
'
' VARIABLEN++++++++++++++++++++++++++++++++++++++++++++++++++++++
' Pfad$ R einzustellender Pfad
' Name$ R Default-Name
' beides als Rückgabe, damit ein eingestellter Pfad
' auch beim weiteren Programmlauf bestehen bleibt
' Text$ Überschrift der Fileselectbox (höchstens 30 Zeichen)
' Filesel Speicher für Hilfs_Screen schon reserviert?
' Hilfs_Screen%L Speicherbereich für Hilfs_Screen
' Screen_Base%L Adresse des aktuellen Bildschirms
' Button Rückgabe von Fileselect
' Dateiname$ R vollständiger ausgewählter Dateiname
' ROUTINEN+++++++++++++++++++++++++++++++++++++++++++++++++++++++
' FN Zentriere__Outline% (Text$, Breite%)
' PROC Info_Kasten(Text$)
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'
DEF PROC Fileselec(R Dateiname$,R Pfad$,R Name$,Text$)
Dateiname$=""
'
IF NOT Filesel% THEN
Hilfs_Screen%L= MEMORY(32000)
Filesel%=-1 ' True%
ENDIF
'
XBIOS (Screen_Base%L/2) ' Adresse des Bildschirms holen
MEMORY_MOVE Screen_Base%L,32000 TO Hilfs_Screen%L ' Bildschirm retten
Info_Kasten(Text$)
'
MOUSEON
FILESELECT (Pfad$,Name$,Button%)
MOUSEOFF
'
MEMORY_MOVE Hilfs_Screen%L, 32000 TO Screen_Base%L ' Bildschirm wiederherstellen
'
IF Button%=1 AND Name$<>"" THEN Dateiname$= FN Dateiname$(Pfad$,Name$)
RETURN
'
'****************************************************************
'*** FN Zentriere_Outline ***
'****************************************************************
'
DEF FN Zentriere_Outline%(Text$,Breite%)=(Breite%-LEN(Text$)*10)\2
'****************************************************************
'*** Info Kasten ***
'****************************************************************
'
DEF PROC Info_Kasten(Text$)
FILL STYLE =1,-1: FILL COLOR =0
PBOX 157,17,326,46: FILL COLOR =1
BOX 157,17,326,46
BOX 160,20,320,32
BOX 161,21,318,30
TEXT STYLE =16: TEXT HEIGHT =13
Ofs%=FN Zentriere_Outline%(Text$,310)
TEXT 164+Ofs%,42,Text$
RETURN
'
'****************************************************************
'*** FN Dateiname$ ***
'****************************************************************
'
' bastelt aus Pfad$ und Name$ einen vollständigen Dateinamen
'
DEF FN Dateiname$(Pfad$, Name$)
Dateiname$= LEFT$(Pfad$, LEN(Pfad$)-INSTR(MIRROR$(Pfad$),"\")+1)+Name$
RETURN Dateiname$
'
'****************************************************************
'*** Desktop_Hintergrund ***
'****************************************************************
'
DEF PROC Desktop_Hintergrund
PRINT CHR$(27)+"f": LINE COLOR =1:
FILL COLOR =1
FILL STYLE =1,-1
PBOX 0,0,10,10: PBOX 0,390,10,10:
PBOX 630,390,10,10: PBOX 630,0,10,10
FILL STYLE =2,4
PRBOX 0,0,640,400
FILL STYLE =1,-1
RETURN
'
'****************************************************************
'*** F_Header ***
'****************************************************************
'
' zeigt Fontheader an - ohne jeglichen Komfort
'
' VARIABLEN++++++++++++++++++++++++++++++++++++++++++++++++++++++
' Ptr%L Adresse des Fontheaders
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'
DEF PROC F_Header(Ptr%L)
CLS
PRINT "Font-ID:"; TAB (20); WPEEK(Ptr%L)
PRINT "Fontgröße:TAB (20);WPEEK(Ptr%L+$2)
N$=""
FOR I%=$4 TO $23
N$=N$+ CHR$( PEEK(Ptr%L+I%))
NEXT I%
PRINT "Fontname:"; TAB (20);N$
PRINT "low ASCII:"; TAB (20);WPEEK(Ptr%L+$24)
PRINT "high ASCII:"; TAB (20);WPEEK(Ptr%L+$26)
PRINT "Top <> Baseline:"; TAB (20);WPEEK(Ptr%L+$28)
PRINT "Ascent <> Baseline:"; TAB (20);WPEEK(Ptr%L+$2A)
PRINT "Half <> Baseline:"; TAB (20);WPEEK(Ptr%L+$2C)
PRINT "Descent <> Baseline:"; TAB (20);WPEEK(Ptr%L+$2E)
PRINT "Bottom <> Baseline:"; TAB (20);WPEEK(Ptr%L+$30)
PRINT "max. Z-Breite:"; TAB (20);WPEEK(Ptr%L+$32)
PRINT "max. ZZ-Breite:"; TAB (20);WPEEK(Ptr%L+$34)
PRINT "Offset links:"; TAB (20);WPEEK(Ptr%L+$36)
PRINT "Offset rechts:"; TAB (20);WPEEK(Ptr%L+$38)
PRINT "Faktor für thick:"; TAB (20);HEX$( WPEEK(Ptr%L+$3A))
PRINT "Dicke underline:"; TAB (20);WPEEK(Ptr%L+$3C)
PRINT "Maske für hell:"; TAB (20);HEX$( WPEEK(Ptr%L+$3E))+" "+ BIN$( WPEEK(Ptr%L+$3E))
PRINT "maske für kursiv:"; TAB (20);HEX$( WPEEK(Ptr%L+$40))+" "+ BIN$( WPEEK(Ptr%L+$40))
PRINT "Flags:"; TAB (20);BIN$( WPEEK(Ptr%L+$42))
PRINT "*Hz_offset:"; TAB (20);HEX$( LPEEK(Ptr%L+$44))
PRINT "*Ch_offset:"; TAB (20);HEX$( LPEEK(Ptr%L+$48))
PRINT "*fnt_data:"; TAB (20);HEX$( LPEEK(Ptr%L+$4C))
PRINT "Breite Datenzeile:"; TAB (20);WPEEK(Ptr%L+$50)
PRINT "Zeichensatzhöhe:"; TAB (20);WPEEK(Ptr%L+$52)
PRINT "*nxt_font:"; TAB (20);HEX$( LPEEK(Ptr%L+$54));
RETURN
'
LIBRARY CODE Gern
Uwe Koloska
Aus: ST-Computer 06 / 1989, Seite 155