begin external class windowtools; MainWindow class FontWindow; begin ref(PromptWindow) ask_wnd; ref(Button) show_button, list_button, stop_button; ref(SubWindow) Font_wnd; ref(FontListWindow) fontlist_wnd; text current_fontname; procedure ClickInButton(b); ref(Button) b; if b == show_button then ShowFont(ask_wnd.ask_for_text_def("Fontname?", current_fontname)) else if b == list_button then ListFontNames; procedure LineChoice(line); text line; ShowFont(line); procedure ShowFont(font_name); text font_name; inspect Font_wnd do begin SetFont(font_name); Clear; if FontExists then begin integer mid_y; current_fontname :- font_name; mid_y := (height + head_height)//2; SetHeading(Current_Fontname); DrawTextPos(width//2, mid_y - font_height, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", CenterPos, CenterPos); DrawTextPos(width//2, mid_y, "abcdefghijklmnopqrstuvwxyz", CenterPos, CenterPos); DrawTextPos(width//2, mid_y + font_height, "1234567890!#$%^&*()_+|~-=\`{}[];'<>?/", CenterPos, CenterPos); end else SetHeading("No font named """ & font_name & """!"); end; procedure ListFontNames; begin if fontlist_wnd == none then begin fontlist_wnd :- new FontListWindow(this FontWindow) .AllowChoice .SetTypeface("courier", 12, true, false) .SetHeading(notext) .SetHeadFont(FontName("helvetica", 12, true, false)) .SetWidth(Font_wnd.width) .SetLines(10) .PlaceLeftBelow(Font_wnd); SetSizeToSubwindowSize; end; fontlist_wnd.ListFontNames; end; SetBackGround("gray25"); ask_wnd :- MakePromptWindow; show_button :- MakeButton("Show font") .SetShortcut('s') .PlaceUpleft; list_button :- MakeButton("List fontnames") .SetShortcut('l'); stop_button :- MakeButton("Stop") .SetShortcut('q') .PlaceUpright; Font_wnd :- new SubWindow(this FontWindow) .SetHeading(" Font ") .SetHeadFont(FontName("helvetica", 12, true, false)) .PlaceLeftBelow(show_button) .SetSize(700, 200) .Show; SetSizeToSubwindowSize; Show; % ShowFont("-*-helvetica-bold-o-normal--*-240-100-100-*-iso8859-1"); ShowFont(Fontname("helvetica", 12, true, true)); stop_button.Wait; end; ScrollWindow class FontListWindow; begin ref(textlist) texts; procedure ListFontNames; begin integer n, m; Clear; Show; if texts == none then FindFontNames; m := texts.count; SetHeading("Showing " & int_as_text(m) & " font-names"); for n := 1 step 1 until m do begin Putline(texts.get(n)); if mod(n, 100) = 0 then SetHeading("Shown " & int_as_text(n) & " of " & int_as_text(m) & " fonts"); end; SetHeading("Choose font to be shown by clicking any of " & int_as_text(m) & " font-names:"); end; procedure FindFontNames; begin text font_name; integer m, n; m := GetFontList(4000); SetHeading(int_as_text(m) & " fonts"); texts :- new textlist(m); font_name :- NextinFontList; n := 0; while font_name =/= notext do begin n := n + 1; texts.put(font_name); if mod(n, 100) = 0 then SetHeading("Read " & int_as_text(n) & " of " & int_as_text(m) & " fonts"); if n < m then font_name :- NextinFontList else font_name :- notext; end; SetHeading("Sorting " & int_as_text(m) & " font-names"); texts.sort; end; end FontListWindow; class textlist(count); integer count; begin text array list(1 : count); integer top; text procedure get(n); integer n; if 1 <= 1 and n <= count then get :- list(n) else get :- notext; procedure put(t); text t; if top < count then begin top := top + 1; list(top) :- t; end; procedure sort; qsort(list, 1, top); procedure qsort(l, b, t); text array l; integer b, t; if b < t then begin text sv, x; integer lb, ll, fa, i; sv :- l(b); lb := b - 1; ll := b; fa := t + 1; i := b + 1; while i < fa do begin x :- l(i); if x < sv then begin lb := lb + 1; ll := ll + 1; l(i) :- l(lb); l(lb) :- x; i := i + 1; end else if x = sv then begin ll := ll + 1; i := i + 1 end else begin fa := fa - 1; l(i) :- l(fa); l(fa) :- x; end; end; qsort(l, b, lb); qsort(l, fa, t); end; top := 0; end; new FontWindow(" Font display "); end;