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:

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.

Es ist auch eine Ausgabe der Font-Daten möglich

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

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
Links

Copyright-Bestimmungen: siehe Über diese Seite
Classic Computer Magazines
[ Join Now | Ring Hub | Random | << Prev | Next >> ]