home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / Clean 1.2.4 / IOInterface / font.icl < prev    next >
Encoding:
Modula Implementation  |  1997-04-23  |  5.9 KB  |  208 lines  |  [TEXT/3PRM]
  1. implementation module font;
  2.  
  3. import StdClass,StdInt, StdString, StdChar, StdBool,StdArray;
  4. import    pointer, quickdraw, fonts;
  5. import    commonDef;
  6.  
  7. ::    Font        =    {    fontNum        :: !FontNum,
  8.                         fontName    :: !FontName,
  9.                         fontStyles    :: ![FontStyle],
  10.                         fontSize    :: !FontSize    };
  11. ::    FontNum        :== Int;
  12. ::    FontName    :== String;
  13. ::    FontStyle    :== String;
  14. ::    FontSize    :== Int;
  15. ::    FontInfo    :== (!Int, !Int, !Int, !Int);
  16.  
  17.  
  18. MinFontSize        :== 6;
  19. MaxFontSize        :== 128;
  20.     
  21. GrafPtrtxFont    :== 68;
  22. GrafPtrtxFace    :== 70;
  23. GrafPtrtxSize    :== 74;
  24.  
  25.  
  26. FontAtts :: !Font -> (!FontNum, !FontName, ![FontStyle], !FontSize);
  27. FontAtts {fontNum=num, fontName=name, fontStyles=style, fontSize=size} = (num,name,style,size);
  28.  
  29. SelectFont :: !FontName ![FontStyle] !FontSize -> (!Bool, !Font);
  30. SelectFont name=:"Chicago" style size
  31.     =    (exists, {fontNum=0, fontName=name, fontStyles=style, fontSize=size1});
  32.     where {
  33.         (exists,tb)    = RealFont 0 size1 NewToolbox;
  34.         size1        = SetBetween size MinFontSize MaxFontSize;
  35.     };
  36. SelectFont name style size
  37. |    fontNr == 0
  38.     =    (dExists, {fontNum=dFontNr, fontName=dName, fontStyles=style, fontSize=size1});
  39.     =    (exists,  {fontNum= fontNr, fontName= name, fontStyles=style, fontSize=size1});
  40.     where {
  41.         (fontNr,  tb )            = GetFNum name NewToolbox;
  42.         (dFontNr, tb1)            = GetFNum dName tb;
  43.         (dExists, _)            = RealFont dFontNr size1 tb1;
  44.         (exists,  _)            = RealFont fontNr  size1 tb;
  45.         size1                    = SetBetween size MinFontSize MaxFontSize;
  46.         (dName, dStyle, dSize)    = DefaultFont;
  47.     };
  48.  
  49. DefaultFont :: (!FontName, ![FontStyle], !FontSize);
  50. DefaultFont = ("Chicago", [], 12);
  51.  
  52. FontNames :: [FontName];
  53. FontNames = FontNames` NewToolbox [0 : FromTo 2 255];
  54.     
  55. FontNames` :: Toolbox [Int] -> [FontName];
  56. FontNames` tb [nr : nrs]
  57. |    "" <> name    = [name : names];
  58.                 = names;
  59.     where {
  60.         (name, tb1) = GetFontName nr String256 tb;
  61.         names        = FontNames` tb1 nrs;
  62.     };
  63. FontNames` _ _ = [];
  64.  
  65. FontStyles :: !FontName -> [FontStyle];
  66. FontStyles name
  67.     =     [    "Bold",
  68.             "Italic",
  69.             "Underline",
  70.             "Outline",
  71.             "Shadow",
  72.             "Condense",
  73.             "Extend"
  74.         ];
  75.  
  76. FontSizes :: !FontName -> [FontSize];
  77. FontSizes name
  78. |    fontNr == 0    = FontSizes` tb1 dFontNr MinFontSize MaxFontSize;
  79.                 = FontSizes` tb  fontNr  MinFontSize MaxFontSize;
  80.     where {
  81.         (fontNr,  tb )            = GetFNum name  NewToolbox;
  82.         (dFontNr, tb1)            = GetFNum dName tb;
  83.         (dName, dStyle, dSize)    = DefaultFont;
  84.     };
  85.     
  86. FontSizes` :: !Toolbox !Int !Int !Int -> [FontSize];
  87. FontSizes` tb fontNr l u
  88. |    l > u    = [];
  89. |    exists    = [l : sizes];
  90.             = sizes;
  91.     where {
  92.         (exists, tb1)    = RealFont fontNr l tb;
  93.         sizes            = FontSizes` tb1 fontNr (inc l) u;
  94.     };
  95.  
  96.  
  97. AccessFont :: !(!Toolbox -> !(!x, !Toolbox)) !Font -> x;
  98. AccessFont f {fontNum=nr,fontStyles=style,fontSize=size}
  99.     =    let! {
  100.             tb4;
  101.         } in x1;
  102.     where {
  103.         (gPtr,    tb1)    = QGetPort NewToolbox;
  104.         (cFont,    tb2)    = GrafPtrGetFont gPtr tb1;
  105.         (_,        tb3)    = GrafPtrSetFont (nr,StyleToStyleID style,size) (0,tb2);
  106.         (x1,    tb4)    = GrafPtrSetFont cFont (f tb3);
  107.     };
  108.  
  109. FontCharWidth :: !Char !Font -> Int;
  110. FontCharWidth char font = AccessFont (QCharWidth char) font;
  111.  
  112. FontCharWidths :: ![Char] !Font -> [Int];
  113. FontCharWidths chars font = AccessFont (GetCharWidths chars) font;
  114.  
  115. GetCharWidths :: ![Char] !Toolbox -> (![Int], !Toolbox);
  116. GetCharWidths [c : cs] tb
  117.     =    ([cWidth : cWidths], tb2);
  118.     where {
  119.         (cWidth, tb1) = QCharWidth c tb;
  120.         (cWidths,tb2) = GetCharWidths cs tb1;
  121.     };
  122. GetCharWidths _ tb = ([], tb);
  123.  
  124. FontStringWidth :: !{#Char} !Font -> Int;
  125. FontStringWidth string font = AccessFont (QStringWidth string) font;
  126.  
  127. FontStringWidths :: ![{#Char}] !Font -> [Int];
  128. FontStringWidths strings font = AccessFont (GetStringWidths strings) font;
  129.  
  130. GetStringWidths :: ![String] !Toolbox -> (![Int], !Toolbox);
  131. GetStringWidths [t : ts] tb
  132.     =    ([sWidth : sWidths], tb2);
  133.     where {
  134.         (sWidth, tb1) = QStringWidth t tb;
  135.         (sWidths,tb2) = GetStringWidths ts tb1;
  136.     };
  137. GetStringWidths _ tb = ([], tb);
  138.  
  139. FontMetrics :: !Font -> FontInfo;
  140. FontMetrics font = AccessFont GetFontInfo font;
  141.  
  142. GetFontInfo :: !Toolbox -> (!FontInfo, !Toolbox);
  143. GetFontInfo tb
  144.     =    ((ascent, descent, maxWidth, leading), tb1);
  145.     where {
  146.         (ascent, descent, maxWidth, leading, tb1) = QGetFontInfo tb;
  147.     };
  148.  
  149. GrafPtrSetFont :: !(!Int, !Int, !Int) !(!x, !Toolbox) -> (!x, !Toolbox);
  150. GrafPtrSetFont (nr, style, size) (x,tb)
  151.     =    (x, QTextSize size (QTextFace style (QTextFont nr tb)));
  152.  
  153. GrafPtrGetFont :: !GrafPtr !Toolbox -> (!(!Int, !Int, !Int), !Toolbox);
  154. GrafPtrGetFont gPtr tb
  155. //    =    ((nr, style >> 8, size), tb3);
  156.     =    ((nr, style, size), tb3);
  157.     where {
  158.         (nr,    tb1) = LoadWord (gPtr + GrafPtrtxFont) tb;
  159.         (style,    tb2) = LoadWord (gPtr + GrafPtrtxFace) tb1;
  160.         (size,    tb3) = LoadWord (gPtr + GrafPtrtxSize) tb2;
  161.     };
  162.  
  163.  
  164. StyleToStyleID :: ![FontStyle] -> Int;
  165. StyleToStyleID ["Bold"        : s] = Bold            +    StyleToStyleID s;
  166. StyleToStyleID ["Italic"    : s] = Italic        +    StyleToStyleID s;
  167. StyleToStyleID ["Underline"    : s] = Underline    +    StyleToStyleID s;
  168. StyleToStyleID ["Outline"    : s] = Outline        +    StyleToStyleID s;
  169. StyleToStyleID ["Shadow"    : s] = Shadow        +    StyleToStyleID s;
  170. StyleToStyleID ["Condense"    : s] = Condense        +    StyleToStyleID s;
  171. StyleToStyleID ["Extend"    : s] = Extend        +    StyleToStyleID s;
  172. StyleToStyleID [_            : s] =                    StyleToStyleID s;
  173. StyleToStyleID _                 = 0;
  174.     
  175.  
  176. FontNameToLowCaps :: !FontName -> String;
  177. FontNameToLowCaps s = FontNameToLowCaps` s (dec (size s));
  178.     
  179. FontNameToLowCaps` :: !FontName !Int -> String;
  180. FontNameToLowCaps` s (-1) = s;
  181. FontNameToLowCaps` s i
  182.     | lowered
  183.         = s` := (i, c`);
  184.         = s`;
  185.     where {
  186.         s`            = FontNameToLowCaps` s (dec i);
  187.         (lowered,c`)= CharToLowChar c;
  188.         c            = s.[i];
  189.     };
  190.  
  191. CharToLowChar :: !Char -> (!Bool, !Char);
  192. CharToLowChar c
  193. |    c >= 'A' && c <= 'Z'    = (True, toChar (toInt c - toInt 'A' + toInt 'a'));
  194.                             = (False, c);
  195.  
  196. FromTo :: !Int !Int -> [Int];
  197. FromTo m n
  198. |    m < n    = [m : FromTo (inc m) n];
  199. |    m > n    = [m : FromTo (dec m) n];
  200.             = [m];
  201.  
  202. String256 :: String;
  203. String256
  204.     =    string128 +++ string128;
  205.     where {
  206.         string128 = "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@";
  207.     };
  208.