home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / oberon / system / fonts.mod (.txt) < prev    next >
Oberon Text  |  1977-12-31  |  10KB  |  316 lines
  1. Syntax10.Scn.Fnt
  2. ParcElems
  3. Alloc
  4. Syntax24b.Scn.Fnt
  5. FoldElems
  6. Syntax10b.Scn.Fnt
  7. (* AMIGA  *)
  8. MODULE Fonts; (* shml/cn 29-Dec-1992, 10-May-94 *)
  9. IMPORT
  10.         SYSTEM, Amiga, DiskFont := AmigaDiskFont, Display, E := AmigaExec, Files, G := AmigaGraphics;
  11. CONST
  12.      FontFileId = 0DBX;
  13.     Name* = ARRAY 32 OF CHAR;
  14.     Font* = POINTER TO FontDesc;
  15.     FontDesc* = RECORD
  16.         name*: Name;
  17.         height*, minX*, maxX*, minY*, maxY*: INTEGER;
  18.         raster*: Display.Font;
  19.         next: Font
  20.     END;
  21.     Default*, First: Font; nofFonts: INTEGER;
  22.     Swap: ARRAY 256 OF CHAR;
  23. PROCEDURE Cleanup;
  24.     raster: Amiga.Font;
  25. BEGIN
  26.     IF Amiga.ChipMemPool=0 THEN
  27.         WHILE First # NIL DO
  28.             raster := SYSTEM.VAL(Amiga.Font, First.raster);
  29.             IF (raster.data#0) & (raster.size#0) THEN E.FreeMem(raster.data, raster.size) END;
  30.             First := First.next
  31.         END
  32.     ELSE
  33.         First:=NIL
  34.     END;
  35.     Default := NIL
  36. END Cleanup;
  37. PROCEDURE ClearRaster(VAR raster:Amiga.Font);
  38.     dummy: Amiga.CharInfo;
  39.     i:INTEGER;
  40. BEGIN
  41.     dummy.dx:=0;
  42.     dummy.x:=0;
  43.     dummy.y:=0;
  44.     dummy.w:=0;
  45.     dummy.h:=0;
  46.     dummy.modulo:=0;
  47.     dummy.data:=0;
  48.     dummy.offset:=0;
  49.     FOR i:=0 TO 255 DO
  50.         raster.info[i]:=dummy
  51.     END;
  52.     raster.data:=0;
  53.     raster.size:=0
  54. END ClearRaster;
  55. PROCEDURE SearchFont(name:ARRAY OF CHAR):Font;
  56.     f:Font;
  57. BEGIN
  58.     f:=First;
  59.     LOOP
  60.         IF f=NIL THEN EXIT END;
  61.         IF name=f.name THEN EXIT END;
  62.         f:=f.next
  63.     END;
  64.     RETURN f
  65. END SearchFont;
  66. PROCEDURE AmigaFont(name: ARRAY OF CHAR): Font;
  67.     TextFontPtr=POINTER TO G.TextFont;
  68.     font:Font;
  69.     raster:Amiga.Font;
  70.     tf:TextFontPtr;
  71.     af:G.TextFontPtr;
  72.     PROCEDURE DuplicateBlock(src:LONGINT; size:LONGINT):LONGINT;
  73.         b:SHORTINT;
  74.         dst:LONGINT;
  75.         i:LONGINT;
  76.     BEGIN
  77.         IF Amiga.ChipMemPool#0 THEN
  78.             dst:=E.AllocPooled(Amiga.ChipMemPool, size)
  79.         ELSE
  80.             dst:=E.AllocMem(size,{E.memChip})
  81.         END;
  82.         FOR i:=0 TO size-1 DO SYSTEM.GET(src+i,b); SYSTEM.PUT(dst+i,b) END;
  83.         RETURN dst
  84.     END DuplicateBlock;
  85.     PROCEDURE OpenAmigaFont(name:ARRAY OF CHAR):G.TextFontPtr;
  86.         fontName:ARRAY 32 OF CHAR;
  87.         fontSize:INTEGER;
  88.         fontStyles:SHORTINT;
  89.         i,j:INTEGER;
  90.         textAttr:G.TextAttr;
  91.     BEGIN
  92.         COPY(name,fontName);
  93.         i:=0; WHILE fontName[i]#"." DO INC(i) END;
  94.         INC(i); j:=i;
  95.         fontSize:=0;
  96.         WHILE ("0"<=fontName[i]) & (fontName[i]<="9") DO
  97.             fontSize:=fontSize*10+ORD(fontName[i])-ORD("0"); INC(i)
  98.         END;
  99.         fontStyles:=0;
  100.         LOOP
  101.             CASE fontName[i] OF
  102.             | "B","b": INC(fontStyles,2); INC(i)
  103.             | "C","c": INC(fontStyles,64); INC(i)
  104.             | "E","e": INC(fontStyles,8); INC(i)
  105.             | "I","i": INC(fontStyles,4); INC(i)
  106.             | "U","u": INC(fontStyles,1); INC(i)
  107.             ELSE EXIT
  108.             END
  109.         END;
  110.         fontName[j]:="f"; fontName[j+1]:="o"; fontName[j+2]:="n"; fontName[j+3]:="t";
  111.         fontName[j+4]:=0X;
  112.         textAttr.name:=SYSTEM.ADR(fontName);
  113.         textAttr.ySize:=fontSize;
  114.         textAttr.style:=fontStyles;
  115.         textAttr.flags:=0;
  116.         RETURN DiskFont.OpenDiskFont(textAttr)
  117.     END OpenAmigaFont;
  118.     PROCEDURE SetFontAndRaster(VAR font:Font; VAR raster:Amiga.Font; tf:TextFontPtr);
  119.     TYPE
  120.         Location=RECORD offset,width:INTEGER END;
  121.         LocationArray=ARRAY 256 OF Location;
  122.         LocationPtr=POINTER TO LocationArray;
  123.         SpaceArray=ARRAY 256 OF INTEGER;
  124.         SpacePtr=POINTER TO SpaceArray;
  125.         KernArray=ARRAY 256 OF INTEGER;
  126.         KernPtr=POINTER TO KernArray;
  127.         ch:INTEGER;
  128.         dx,x,y,w,h:SHORTINT;
  129.         i:INTEGER;
  130.         kern:KernPtr;
  131.         loc:LocationPtr;
  132.         minX,maxX:INTEGER;
  133.         space:SpacePtr;
  134.         li:LONGINT;
  135.     BEGIN
  136.         loc:=SYSTEM.VAL(LocationPtr, tf.charLoc);
  137.         space:=SYSTEM.VAL(SpacePtr, tf.charSpace);
  138.         kern:=SYSTEM.VAL(KernPtr, tf.charKern);
  139.         y:=SHORT(tf.baseline-tf.ySize+1);
  140.         h:=SHORT(tf.ySize);
  141.         font.minY:=y;
  142.         font.maxY:=y+h;
  143.         minX:=MAX(INTEGER); maxX:=MIN(INTEGER);
  144.         raster.size:=tf.modulo*h;
  145.         raster.data:=DuplicateBlock(tf.charData,raster.size);
  146.         FOR ch:=ORD(tf.loChar) TO ORD(tf.hiChar) DO
  147.             i:=ch-ORD(tf.loChar);
  148.             IF space#NIL THEN dx:=SHORT(space[i]) ELSE dx:=SHORT(tf.xSize) END;
  149.             x:=0; IF kern#NIL THEN dx:=dx+SHORT(kern[i]); x:=SHORT(kern[i]); END;
  150.             IF loc#NIL THEN w:=SHORT(loc[i].width) ELSE w:=SHORT(tf.xSize) END;
  151.             IF x<minX THEN minX:=x END;
  152.             IF x+w>maxX THEN maxX:=x+w END;
  153.             raster.info[ch].dx:=dx;
  154.             raster.info[ch].x:=x;
  155.             raster.info[ch].y:=y;
  156.             raster.info[ch].w:=w;
  157.             raster.info[ch].h:=h;
  158.             raster.info[ch].modulo:=tf.modulo;
  159.             raster.info[ch].data:=raster.data;
  160.             IF loc#NIL THEN raster.info[ch].offset:=loc[i].offset ELSE raster.info[ch].offset:=w*i END
  161.         END;
  162.         font.height:=h;
  163.         font.minX:=minX;
  164.         font.maxX:=maxX;
  165.         font.raster:=SYSTEM.VAL(Display.Font,raster)
  166.     END SetFontAndRaster;
  167. BEGIN
  168.     font:=Default;
  169.     af:=OpenAmigaFont(name);
  170.     tf:=SYSTEM.VAL(TextFontPtr, af);
  171.     IF tf#NIL THEN
  172.         NEW(raster);
  173.         ClearRaster(raster);
  174.         NEW(font);
  175.         IF font=NIL THEN HALT(127) END;
  176.         SetFontAndRaster(font,raster,tf);
  177.         raster.amigaFont:=af;
  178.         COPY(name,font.name);
  179.         font.next:=First;
  180.         First:=font;
  181.         G.CloseFont(af)
  182.     END;
  183.     RETURN font
  184. END AmigaFont;
  185. PROCEDURE OberonFont(name: ARRAY OF CHAR): Font;
  186.     RunRec=RECORD
  187.         beg, end: INTEGER
  188.     END;
  189.     RunRecArray=ARRAY 16 OF RunRec;
  190.     ch:CHAR;
  191.     file:Files.File;
  192.     font:Font;
  193.     nOfRuns: INTEGER;
  194.     raster: Amiga.Font;
  195.     rider:Files.Rider;
  196.     run:RunRecArray;
  197.     PROCEDURE ReadShort(VAR r: Files.Rider; VAR x: SHORTINT);
  198.         val: INTEGER;
  199.     BEGIN
  200.         Files.ReadInt(r, val); x := SHORT(val)
  201.     END ReadShort;
  202.     PROCEDURE ReadFontHeader(VAR r: Files.Rider; VAR f:Font; VAR nOfRuns:INTEGER; VAR run:RunRecArray);
  203.         k:INTEGER;
  204.     BEGIN
  205.         Files.ReadInt(r,f.height);
  206.         Files.ReadInt(r,f.minX);
  207.         Files.ReadInt(r,f.maxX);
  208.         Files.ReadInt(r,f.minY);
  209.         Files.ReadInt(r,f.maxY);
  210.         Files.ReadInt(r,nOfRuns);
  211.         FOR k := 0 TO nOfRuns-1 DO
  212.             Files.ReadInt(r,run[k].beg);
  213.             Files.ReadInt(r,run[k].end)
  214.         END
  215.     END ReadFontHeader;
  216.     PROCEDURE ReadRaster(VAR r:Files.Rider; VAR raster:Amiga.Font; VAR nOfRuns:INTEGER; VAR run:RunRecArray);
  217.         a:LONGINT;
  218.         j, bytesPerRow:LONGINT;
  219.         i,k,m:INTEGER;
  220.         nOfBytes:LONGINT;
  221.     BEGIN
  222.         nOfBytes:=0;
  223.         FOR k:=0 TO nOfRuns-1 DO
  224.             FOR m:=run[k].beg TO run[k].end-1 DO
  225.                 ReadShort(r,raster.info[m].dx);
  226.                 ReadShort(r,raster.info[m].x);
  227.                 ReadShort(r,raster.info[m].y);
  228.                 ReadShort(r,raster.info[m].w);
  229.                 ReadShort(r,raster.info[m].h);
  230.                 raster.info[m].modulo:=2*((raster.info[m].w+15) DIV 16);
  231.                 nOfBytes:=nOfBytes+raster.info[m].modulo*raster.info[m].h
  232.             END
  233.         END;
  234.         IF Amiga.ChipMemPool#0 THEN
  235.             raster.data:=E.AllocPooled(Amiga.ChipMemPool, nOfBytes)
  236.         ELSE
  237.             raster.data:=E.AllocMem(nOfBytes,{E.memChip})
  238.         END;
  239.         raster.size:=nOfBytes;
  240.         a:=raster.data;
  241.         FOR k:=0 TO nOfRuns-1 DO
  242.             FOR m:=run[k].beg TO run[k].end-1 DO
  243.                 bytesPerRow:=(raster.info[m].w+7) DIV 8;
  244.                 raster.info[m].data:=a;
  245.                 raster.info[m].offset:=0;
  246.                 INC(a,LONG(raster.info[m].modulo)*(raster.info[m].h-1));
  247.                 FOR i:=1 TO raster.info[m].h DO
  248.                     FOR j:=1 TO bytesPerRow DO
  249.                         Files.Read(r,ch);
  250.                         SYSTEM.PUT(a,Swap[ORD(ch)]);
  251.                         INC(a)
  252.                     END;
  253.                     DEC(a,bytesPerRow+raster.info[m].modulo)
  254.                 END;
  255.                 a:=raster.info[m].data+raster.info[m].modulo*raster.info[m].h
  256.             END
  257.         END
  258.     END ReadRaster;
  259. BEGIN
  260.     file:=Files.Old(name);
  261.     IF file#NIL THEN
  262.         Files.Set(rider,file,0); Files.Read(rider,ch);
  263.         IF ch=FontFileId THEN
  264.             Files.Read(rider,ch);    (*skip abstraction*)
  265.             Files.Read(rider,ch);    (*skip family*)
  266.             Files.Read(rider,ch);    (*skip variant*)
  267.             NEW(font);
  268.             ReadFontHeader(rider,font,nOfRuns,run);
  269.             NEW(raster);
  270.             ClearRaster(raster);
  271.             ReadRaster(rider,raster,nOfRuns,run);
  272.             raster.amigaFont:=0;
  273.             font.raster:=SYSTEM.VAL(Display.Font,raster);
  274.             COPY(name,font.name);
  275.             font.next:=First;
  276.             First:=font;
  277.         ELSE
  278.             font:=Default
  279.         END
  280.     ELSE
  281.         font:=Default
  282.     END;
  283.     RETURN font
  284. END OberonFont;
  285. PROCEDURE This*(name: ARRAY OF CHAR):Font;(*
  286. Load the named font, unless it is already loaded. Depending on the name, either an Oberon or an Amiga font is loaded.
  287. If the font name terminates with .Scn.Fnt then the named file is loaded as an Oberon Font.
  288. Otherwise, the name is assumed to be of the form fontname.size and split into its two components. Then the Amiga font with that name and size is loaded.
  289.     font:Font;
  290.     i:INTEGER;
  291. BEGIN
  292.     font:=SearchFont(name);
  293.     IF font=NIL THEN
  294.         i:=-1; REPEAT INC(i) UNTIL name[i] = 0X;
  295.         IF (i >= 9) & (name[i-8] = ".") & (name[i-7] = "S") & (name[i-6] = "c") & (name[i-5] = "n") & (name[i-4] = ".")
  296.                 & (name[i-3] = "F") & (name[i-2] = "n") & (name[i-1] = "t") THEN font:=OberonFont(name)
  297.         ELSE font:=AmigaFont(name)
  298.         END
  299.     END;
  300.     RETURN font
  301. END This;
  302. PROCEDURE InitSwap;
  303.     VAR i: INTEGER;
  304. BEGIN
  305.     FOR i:=0 TO 255 DO
  306.         Swap[i]:=SYSTEM.VAL(CHAR, Amiga.SwapBits(CHR(i)))
  307. END InitSwap;
  308. BEGIN
  309.     InitSwap;
  310.     First:=NIL;
  311.     nofFonts:=0;
  312.     Default:=This("Syntax10.Scn.Fnt");
  313.     Amiga.Assert(Default#NIL,"Default font not found");
  314.     Amiga.TermProcedure(Cleanup)
  315. END Fonts.
  316.