suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add %%DocumentFonts to PS output

Browse Source 
svn: r10453
This commit is contained in:
Matthew Flatt 2008-06-25 21:10:46 +00:00
parent da82fe2a2d
commit 4525e63050
18 changed files with 176 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/mred/mred.ss
View File

@ -35,7 +35,9 @@
afm-draw-text
afm-get-text-extent
afm-expand-name
afm-glyph-exists?)
afm-glyph-exists?
afm-record-font
afm-fonts-string)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

43
collects/mred/private/afm.ss
View File

@ -5,7 +5,9 @@
(provide (protect afm-draw-text
afm-get-text-extent
afm-expand-name
afm-glyph-exists?)
afm-glyph-exists?
afm-record-font
afm-fonts-string)
current-ps-afm-file-paths
current-ps-cmap-file-paths)
@ -498,16 +500,19 @@
(* scale (font-internal-leading font)))))
;; pen is positioned at text top-left:
(define (afm-draw-text font-name size string out kern? sym-map?)
(define (afm-draw-text font-name size string out kern? sym-map? used-fonts)
(let* ([l (map-symbols sym-map? (string->list string))]
[used-fonts (or used-fonts (make-hash-table 'equal))]
[font (or (get-font font-name)
(make-font 0 0 0 0 #hash() #f #f))]
[show-simples (lambda (simples special-font-name special-font)
(unless (null? simples)
(when special-font
(fprintf out "currentfont~n/~a findfont~n~a scalefont setfont~n"
(afm-expand-name special-font-name)
size))
(let ([name (afm-expand-name special-font-name)])
(hash-table-put! used-fonts name #t)
(fprintf out "currentfont~n/~a findfont~n~a scalefont setfont~n"
name
size)))
(if (font-is-cid? (or special-font font))
(fprintf out "<~a> show\n"
(apply
@ -626,7 +631,8 @@
(show-simples simples special-font-name special-font)
;; Future work: a box. For now, we just skip some space.
(fprintf out "~a 0 rmoveto\n" (/ size 2))
(loop (cdr l) null #f #f)))]))))
(loop (cdr l) null #f #f)))])))
used-fonts)
;; ----------------------------------------
;; Name expansion
@ -638,6 +644,31 @@
(string-append font-name "-" (bytes->string/latin-1 (font-char-set-name f)))
font-name)))
(define (afm-record-font name used-fonts)
(let ([used-fonts (or used-fonts (make-hash-table 'equal))])
(hash-table-put! used-fonts name #t)
used-fonts))
(define (afm-fonts-string used-fonts)
(if (hash-table? used-fonts)
(let ([s (open-output-string)]
[pos 0])
(hash-table-for-each
used-fonts
(lambda (k v)
(let ([len (string-length k)])
(when ((+ len pos) . > . 50)
(fprintf s "\n%%+ ")
(set! pos 0))
(unless (zero? pos)
(display " " s)
(set! pos (add1 pos)))
(display k s)
(set! pos (+ pos len)))))
(get-output-string s))
""))
;; ----------------------------------------
;; Font substitution

4
src/mred/mred.cxx
View File

@ -2474,8 +2474,8 @@ static void MrEdSchemeMessages(char *msg, ...)
{
GC_CAN_IGNORE va_list args;
#if WINDOW_STDIO
char *arg_s;
long arg_d, arg_l;
char *arg_s = NULL;
long arg_d = 0, arg_l = 0;
# define VSP_BUFFER_SIZE 4096
char arg_buffer[VSP_BUFFER_SIZE];
#endif

42
src/mred/wxs/wxscheme.cxx
View File

@ -1333,6 +1333,7 @@ static Scheme_Object *wxSchemeGetFontList(int argc, Scheme_Object **argv)
/***********************************************************************/
static Scheme_Object *ps_draw_text, *ps_get_text_extent, *ps_expand_name, *ps_glyph_exists;
static Scheme_Object *ps_record_font, *ps_fonts_string;
static Scheme_Object *SetPSProcs(int, Scheme_Object *a[])
{
@ -1344,15 +1345,17 @@ static Scheme_Object *SetPSProcs(int, Scheme_Object *a[])
ps_get_text_extent = a[1];
ps_expand_name = a[2];
ps_glyph_exists = a[3];
ps_record_font = a[4];
ps_fonts_string = a[5];
return scheme_void;
}
void wxPostScriptDrawText(Scheme_Object *f, const char *fontname,
const char *text, int dt, Bool combine, int use16,
double font_size, int sym_map)
void *wxPostScriptDrawText(Scheme_Object *f, const char *fontname,
const char *text, int dt, Bool combine, int use16,
double font_size, int sym_map, void *used_fonts)
{
if (ps_draw_text) {
Scheme_Object *a[6], *v;
Scheme_Object *a[7], *v;
v = scheme_make_utf8_string(fontname);
a[0] = v;
@ -1365,8 +1368,9 @@ void wxPostScriptDrawText(Scheme_Object *f, const char *fontname,
a[3] = f;
a[4] = (combine ? scheme_true : scheme_false);
a[5] = (sym_map ? scheme_true : scheme_false);
a[6] = (used_fonts ? (Scheme_Object *)used_fonts : scheme_false);
scheme_apply(ps_draw_text, 6, a);
return scheme_apply(ps_draw_text, 7, a);
}
}
@ -1442,6 +1446,32 @@ Bool wxPostScriptGlyphExists(const char *fontname, int c, int sym_map)
return TRUE;
}
extern void *wxPostScriptRecordFont(const char *fontname, void *used_fonts)
{
if (ps_record_font) {
Scheme_Object *a[2], *v;
v = scheme_make_sized_offset_utf8_string((char *)fontname, 0, -1);
a[0] = v;
a[1] = (used_fonts ? (Scheme_Object *)used_fonts : scheme_false);
return scheme_apply(ps_record_font, 2, a);
}
return scheme_null;
}
extern char *wxPostScriptFontsToString(void *used_fonts)
{
if (ps_fonts_string && used_fonts) {
Scheme_Object *a[1], *s;
a[0] = (Scheme_Object *)used_fonts;
s = scheme_apply(ps_fonts_string, 1, a);
if (SCHEME_CHAR_STRINGP(s)) {
s = scheme_char_string_to_byte_string(s);
return SCHEME_BYTE_STR_VAL(s);
}
}
return "";
}
/***********************************************************************/
/* panel color */
/***********************************************************************/
@ -3269,7 +3299,7 @@ static void wxScheme_Install(Scheme_Env *global_env)
scheme_install_xc_global("set-ps-procs",
scheme_make_prim_w_arity(CAST_SP SetPSProcs,
"set-ps-procs",
4, 4),
6, 6),
global_env);

1
src/mzscheme/include/mzscheme.exp
View File

@ -397,6 +397,7 @@ scheme_write_evt_via_write
scheme_write_special_evt_via_write_special
scheme_open_input_file
scheme_open_output_file
scheme_open_input_output_file
scheme_open_output_file_with_mode
scheme_make_file_input_port
scheme_make_named_file_input_port

1
src/mzscheme/include/mzscheme3m.exp
View File

@ -407,6 +407,7 @@ scheme_write_evt_via_write
scheme_write_special_evt_via_write_special
scheme_open_input_file
scheme_open_output_file
scheme_open_input_output_file
scheme_open_output_file_with_mode
scheme_make_file_input_port
scheme_make_named_file_input_port

1
src/mzscheme/include/mzwin.def
View File

@ -385,6 +385,7 @@ EXPORTS
scheme_write_special_evt_via_write_special
scheme_open_input_file
scheme_open_output_file
scheme_open_input_output_file
scheme_open_output_file_with_mode
scheme_make_file_input_port
scheme_make_named_file_input_port

1
src/mzscheme/include/mzwin3m.def
View File

@ -399,6 +399,7 @@ EXPORTS
scheme_write_special_evt_via_write_special
scheme_open_input_file
scheme_open_output_file
scheme_open_input_output_file
scheme_open_output_file_with_mode
scheme_make_file_input_port
scheme_make_named_file_input_port

11
src/mzscheme/src/port.c
View File

@ -4022,6 +4022,17 @@ Scheme_Object *scheme_open_output_file(const char *name, const char *who)
return scheme_do_open_output_file((char *)who, 0, 2, a, 0);
}
Scheme_Object *scheme_open_input_output_file(const char *name, const char *who, Scheme_Object **oport)
{
Scheme_Object *a[2];
a[0]= scheme_make_path(name);
a[1] = truncate_replace_symbol;
scheme_do_open_output_file((char *)who, 0, 2, a, 1);
*oport = scheme_multiple_array[1];
return scheme_multiple_array[0];
}
Scheme_Object *scheme_open_output_file_with_mode(const char *name, const char *who, int text)
{
Scheme_Object *a[3];

1
src/mzscheme/src/schemef.h
View File

@ -791,6 +791,7 @@ MZ_EXTERN Scheme_Object *scheme_write_special_evt_via_write_special(Scheme_Outpu
MZ_EXTERN Scheme_Object *scheme_open_input_file(const char *name, const char *who);
MZ_EXTERN Scheme_Object *scheme_open_output_file(const char *name, const char *who);
MZ_EXTERN Scheme_Object *scheme_open_input_output_file(const char *name, const char *who, Scheme_Object **oport);
MZ_EXTERN Scheme_Object *scheme_open_output_file_with_mode(const char *name, const char *who, int text);
MZ_EXTERN Scheme_Object *scheme_make_file_input_port(FILE *fp);

1
src/mzscheme/src/schemex.h
View File

@ -667,6 +667,7 @@ Scheme_Object *(*scheme_write_special_evt_via_write_special)(Scheme_Output_Port
Scheme_Object *special);
Scheme_Object *(*scheme_open_input_file)(const char *name, const char *who);
Scheme_Object *(*scheme_open_output_file)(const char *name, const char *who);
Scheme_Object *(*scheme_open_input_output_file)(const char *name, const char *who, Scheme_Object **oport);
Scheme_Object *(*scheme_open_output_file_with_mode)(const char *name, const char *who, int text);
Scheme_Object *(*scheme_make_file_input_port)(FILE *fp);
Scheme_Object *(*scheme_make_named_file_input_port)(FILE *fp, Scheme_Object *name);

1
src/mzscheme/src/schemex.inc
View File

@ -445,6 +445,7 @@
scheme_extension_table->scheme_write_special_evt_via_write_special = scheme_write_special_evt_via_write_special;
scheme_extension_table->scheme_open_input_file = scheme_open_input_file;
scheme_extension_table->scheme_open_output_file = scheme_open_output_file;
scheme_extension_table->scheme_open_input_output_file = scheme_open_input_output_file;
scheme_extension_table->scheme_open_output_file_with_mode = scheme_open_output_file_with_mode;
scheme_extension_table->scheme_make_file_input_port = scheme_make_file_input_port;
scheme_extension_table->scheme_make_named_file_input_port = scheme_make_named_file_input_port;

1
src/mzscheme/src/schemexm.h
View File

@ -445,6 +445,7 @@
#define scheme_write_special_evt_via_write_special (scheme_extension_table->scheme_write_special_evt_via_write_special)
#define scheme_open_input_file (scheme_extension_table->scheme_open_input_file)
#define scheme_open_output_file (scheme_extension_table->scheme_open_output_file)
#define scheme_open_input_output_file (scheme_extension_table->scheme_open_input_output_file)
#define scheme_open_output_file_with_mode (scheme_extension_table->scheme_open_output_file_with_mode)
#define scheme_make_file_input_port (scheme_extension_table->scheme_make_file_input_port)
#define scheme_make_named_file_input_port (scheme_extension_table->scheme_make_named_file_input_port)

2
src/mzscheme/src/syntax.c
View File

@ -5431,8 +5431,6 @@ define_for_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Exp
Scheme_Object *scheme_make_environment_dummy(Scheme_Comp_Env *env)
{
Scheme_Object *dummy;
/* Get a prefixed-based accessor for a dummy top-level bucket. It's
used to "link" to the right environment at run time. The `begin'
symbol is arbitrary; the top-level/prefix support handles a symbol

2
src/mzscheme/src/thread.c
View File

@ -6685,7 +6685,7 @@ Scheme_Object *scheme_make_namespace(int argc, Scheme_Object *argv[])
env = env->exp_env;
}
return env;
return (Scheme_Object *)env;
}
static Scheme_Object *namespace_p(int argc, Scheme_Object **argv)

81
src/wxcommon/PSDC.cxx
View File

@ -67,9 +67,9 @@
#include "wx_rgn.h"
#include "../mzscheme/include/scheme.h"
extern void wxPostScriptDrawText(Scheme_Object *f, const char *fontname,
const char *text, int dt, Bool combine, int use16,
double font_size, int symbol_map);
extern void *wxPostScriptDrawText(Scheme_Object *f, const char *fontname,
const char *text, int dt, Bool combine, int use16,
double font_size, int symbol_map, void *used_fonts);
extern void wxPostScriptGetTextExtent(const char *fontname,
const char *text, int dt, int len, Bool combine, int use16,
double font_size,
@ -77,6 +77,8 @@ extern void wxPostScriptGetTextExtent(const char *fontname,
int symbol_map);
extern char *wxPostScriptFixupFontName(const char *fontname);
extern Bool wxPostScriptGlyphExists(const char *fontname, int c, int symbol_map);
extern void *wxPostScriptRecordFont(const char *fontname, void *used_fonts);
extern char *wxPostScriptFontsToString(void *used_fonts);
# define YSCALE(y) ((paper_h) - ((y) * user_scale_y + device_origin_y))
# define XSCALE(x) ((x) * user_scale_x + device_origin_x)
@ -137,12 +139,21 @@ wxPrintPaperDatabase *wxThePrintPaperDatabase;
/**************************************************/
wxPSStream::wxPSStream(char *file) {
f = scheme_open_output_file(file, "post-script-dc%");
Scheme_Object *o;
f_in = scheme_open_input_output_file(file, "post-script-dc%", &o);
f = o;
int_width = 0;
}
wxPSStream::~wxPSStream(void) {
if (f) scheme_close_output_port((Scheme_Object *)f);
if (f_in) {
scheme_close_input_port((Scheme_Object *)f_in);
f_in = NULL;
}
if (f) {
scheme_close_output_port((Scheme_Object *)f);
f = NULL;
}
}
int wxPSStream::good(void) {
@ -202,6 +213,14 @@ void wxPSStream::width(int w) {
int_width = w;
}
long wxPSStream::read_at(long pos, char *buf, long amt) {
scheme_set_file_position((Scheme_Object *)f_in, pos);
return scheme_get_byte_string("post-script%", (Scheme_Object *)f_in,
buf, 0, amt,
0, 0, NULL);
}
/**************************************************/
@ -1362,8 +1381,11 @@ void wxPostScriptDC::DrawText(DRAW_TEXT_CONST char *text, double x, double y,
if (!current_font_name
|| (next_font_size != current_font_size)
|| strcmp(next_font_name, current_font_name)) {
pstream->Out("/"); pstream->Out(wxPostScriptFixupFontName(next_font_name)); pstream->Out(" findfont\n");
char *fn;
pstream->Out("/"); fn = wxPostScriptFixupFontName(next_font_name); pstream->Out(fn); pstream->Out(" findfont\n");
pstream->Out(next_font_size); pstream->Out(" scalefont setfont\n");
used_fonts = wxPostScriptRecordFont(fn, used_fonts);
current_font_size = next_font_size;
current_font_name = next_font_name;
@ -1409,8 +1431,8 @@ void wxPostScriptDC::DrawText(DRAW_TEXT_CONST char *text, double x, double y,
}
sym_map = current_font->GetFamily() == wxSYMBOL;
wxPostScriptDrawText((Scheme_Object *)pstream->f, name, text, dt, combine, use16, current_font_size,
sym_map);
used_fonts = wxPostScriptDrawText((Scheme_Object *)pstream->f, name, text, dt, combine, use16, current_font_size,
sym_map, used_fonts);
if ((angle != 0.0) || (user_scale_x != 1) || (user_scale_y != 1)) {
pstream->Out("grestore\n");
@ -1542,11 +1564,22 @@ Bool wxPostScriptDC::StartDoc (char *message)
}
boundingboxpos = pstream->tellp();
pstream->Out("%%BoundingBox: -00000 -00000 -00000 -00000\n");
pstream->Out("%%Pages: -00000\n");
if (landscape)
pstream->Out("%%Orientation: Landscape\n");
{
int i;
pstream->Out("%%DocumentFonts: ");
fontlistpos = pstream->tellp();
for (i = 0; i < 5; i++) {
pstream->Out(" ");
}
pstream->Out("\n");
}
pstream->Out("%%EndComments\n\n");
pstream->Out(wxPostScriptHeaderEllipse);
@ -1570,6 +1603,7 @@ void wxPostScriptDC::EndDoc (void)
{
double llx, lly, urx, ury;
double minx, miny, maxx, maxy;
long last_pos;
if (!pstream)
return;
@ -1611,6 +1645,8 @@ void wxPostScriptDC::EndDoc (void)
if (ury <= lly)
ury = lly + 1;
last_pos = pstream->tellp();
// The Adobe specifications call for integers; we round as to make
// the bounding larger.
pstream->seekp(boundingboxpos);
@ -1627,6 +1663,33 @@ void wxPostScriptDC::EndDoc (void)
pstream->width(5);
pstream->Out((page_number - 1)); pstream->Out("\n");
{
char *fnts;
long len;
fnts = wxPostScriptFontsToString(used_fonts);
pstream->seekp(fontlistpos);
len = strlen(fnts);
if (len <= 50) {
pstream->Out(fnts);
} else {
long a, bot, delta = len - 50;
char *buf;
buf = new WXGC_ATOMIC char[4096];
for (a = last_pos; a > fontlistpos; ) {
bot = a - 4095;
if (bot < fontlistpos)
bot = fontlistpos;
pstream->read_at(bot, buf, a - bot);
buf[a - bot] = 0;
pstream->seekp(bot + delta);
pstream->Out(buf);
a = bot;
}
pstream->seekp(fontlistpos);
pstream->Out(fnts);
}
}
DELETE_OBJ pstream;
pstream = NULL;

4
src/wxcommon/PSDC.h
View File

@ -59,7 +59,7 @@ class wxPostScriptDC: public wxDC
int page_number;
wxPSStream *pstream; // PostScript output stream
char *filename;
long boundingboxpos;
long boundingboxpos, fontlistpos;
unsigned char currentRed;
unsigned char currentGreen;
unsigned char currentBlue;
@ -78,6 +78,8 @@ class wxPostScriptDC: public wxDC
int mode, use_paper_bbox, as_eps;
char *preview_cmd, *print_cmd, *print_opts;
void *used_fonts;
// Create a printer DC
wxPostScriptDC(Bool interactive = TRUE, wxWindow *parent = NULL, Bool usePaperBBox = FALSE, Bool asEPS = TRUE);

4
src/wxcommon/Region.h
View File

@ -11,7 +11,7 @@
class wxPSStream : public wxObject {
public:
void *f;
void *f, *f_in;
int int_width;
wxPSStream(char *file);
~wxPSStream(void);
@ -27,6 +27,8 @@ class wxPSStream : public wxObject {
void seekp(long pos);
void width(int w);
long read_at(long pos, char *buf, long amt);
};
class wxPostScriptDC;