#include    <stdio.h>
#include    <stdlib.h>
#include    <string.h>
#include    <math.h>

#define DPI     600
#define RAD     (180./3.14159)
#define ST      (0.2086)    /* sin(slope) */
#define CT      (0.9780)    /* cos(slope) */

int plot(double xp, double yp, int md);
int clspath(int join);
int penatr(int jpen, int icol, int ityp, double thick);
int newpen(int npen);
int qpatr(int mpen, int *lcol, int *ltyp, double *wthick);
int qpsfp(FILE **fps);
int qapos(int *ixp, int *iyp);
int where(double *wx, double *wy, double *wfac);
int wrect(double xl, double yl, double xsz, double ysz);
int wcirc(double xc, double yc, double radius, double ang1, double ang2);
int paintc(double xc, double yc, double radius);
int paintr(double xorg, double yorg, double wide, double high);
int paintp(float xa[], float ya[], int npt, int inc);

static int lfnt=1, kfnt=0, txcol=0, bgcol=-999;
static double ca=100., sa = 0.;

int lstyle(char *fnt, double high, double ang, int tcol, int bcol)
{   int i, k, rc;
    double wx, wy, wfac;
    char *ff, sfnt[]="TtHhCcKkSsMmGg", smod[]="BbFfOoIiNnRr";
    if (*fnt == '\0') rc = 0;
    else if ((ff=strchr(sfnt,*fnt)) == NULL)
        { fprintf(stderr, "lstyle: unknown font\n"); rc = 1; }
    else {
        k = (ff-sfnt)/2; if (k < 5) kfnt = k*4; else kfnt = k*2 + 2;
        for (i=1,fnt++; i<3; i++,fnt++) {
            if (*fnt == '\0') break;
            if ((ff=strchr(smod,*fnt)) != NULL) {
                k = (ff-smod)/2;
                if (k == 0)      kfnt |= 0x02;
                else if (k == 1) kfnt &= 0x1d;
                else if (k < 4)  kfnt |= 0x01;
                else             kfnt &= 0x1e;
            }
        }
        rc = 0; lfnt = 1;
    }
    if (high <= 0.) { fprintf(stderr, "lstyle: illegal size\n"); rc = 1; }
    else {
        where(&wx, &wy, &wfac);
        lfnt = 1; high *= (DPI/2.54) * wfac;
        ca = high*cos(ang/RAD); sa = high*sin(ang/RAD);
    }
    txcol = tcol; if ((tcol<-255) || (tcol>0xffffff)) txcol = 0;
    bgcol = bcol; if ((bcol<-255) || (bcol>0xffffff)) bgcol = -999;
    return(rc);
}

int ptext(char *text, int ltxt, double xp, double yp, int kp)
{   int pen, col, typ, ixp, iyp, r, g, b, i, c, c2;
    double wx, wy, wfac, wt; FILE *fp;
    char *ftnam[] = {
        "Times-Roman",          "Times-Italic",
        "Times-Bold",           "Times-BoldItalic",
        "Helvetica",            "Helvetica-Oblique",
        "Helvetica-Bold",       "Helvetica-BoldOblique",
        "Courier",              "Courier-Oblique",
        "Courier-Bold",         "Courier-BoldOblique",
        "Ryumin-Light-RKSJ-H",  "GothicBBB-Medium-RKSJ-H",
        "Symbol",               "Symbol" };
    if ((*text=='\0') || (ltxt<=0)) return(0);
    if ((kp<0) || (kp>2)) kp = 0;
    if (where(&wx,&wy,&wfac) < 0)
        { fprintf(stderr, "ptext: error at calling where\n"); return(-1); }
    pen = qpatr(0,&col,&typ,&wt); qpsfp(&fp);
    plot(xp,yp,3); qapos(&ixp,&iyp);
    if (lfnt != 0) {
        if (kfnt < 12) fprintf(fp, "/%s findfont\n", ftnam[kfnt]);
        else fprintf(fp, "/%s findfont\n", ftnam[kfnt/2+6]);
        if ((kfnt>12) && ((kfnt%2)==1))
            fprintf(fp, "[%.2f %.2f %.2f %.2f 0 0]",
                    ca,sa,(ca*ST-sa*CT),(ca*CT+sa*ST));
        else fprintf(fp, "[%.2f %.2f %.2f %.2f 0 0]", ca,sa,-sa,ca);
        fprintf(fp, " makefont setfont\n"); lfnt = 0;
    }
    fputc('(', fp);
    for (i=1; ((i<=ltxt) && (*text!='\0')); i++,text++) {
        c = (unsigned char)*text;
        if ((c>=0x20) && (c<=0x7e)) {
            if (c == '\\') fprintf(fp, "\\\\");
            else if (c == '(') fprintf(fp, "\\(");
            else if (c == ')') fprintf(fp, "\\)");
            else fputc(c, fp);
        }
        else if ((kfnt>=12) && (kfnt<=15) && (i<ltxt)) {
            c2 = (unsigned char)*(text+1);
                /****************************************************/
                /*  Accepts Zenkaku codes both in EUC and in SJIS,  */
                /*    though conflicted codes are regarded as EUC.  */
                /*  If 2nd byte of Zenkaku code (in SJIS string)    */
                /*    is '\'(0x5c), another '\' is required.        */
                /****************************************************/
            if ((c>=0xa1) && (c<=0xfe) && (c2>=0xa1) && (c2<=0xfe)) {
                                /* Zenkaku EUC conversion into SJIS */
                if ((c%2) == 0) c2 -= 0x02; else c2 -= 0x60;
                if (c2 <= 0x7f) c2--; c = (c-0xa1)/2 + 0x81;
                if (c >= 0xa0) c += 0x40;
            }
            if ((((c>=0x81) && (c<=0x9f)) || ((c>=0xe0) && (c<=0xef)))
                    && ((c2>=0x40) && (c2<=0xfc) && (c2!=0x7f))) {
                fprintf(fp, "\\%3o", c); i++; text++;
                if (c2 >=0x80) fprintf(fp, "\\%3o", c2);
                else if (c2 == '\\') fprintf(fp, "\\\\");
                else if (c2 == '(') fprintf(fp, "\\(");
                else if (c2 == ')') fprintf(fp, "\\)");
                else fputc(c2, fp);
            }
        }
    }
    fputc(')', fp); fputc('\n', fp);
    if (bgcol == -999) {
        if (kp == 1) fprintf(fp, " dup stringwidth neg exch neg exch\n");
        else if (kp == 2) {
            fprintf(fp, " dup stringwidth 2 div %.0f add neg exch", ca*0.35);
            fprintf(fp, " 2 div %.0f sub neg exch\n", sa*0.35);
        }
    }
    else {
        fprintf(fp, " dup stringwidth\n");
        if (kp == 1)
            fprintf(fp, "dup neg exch 3 2 roll dup neg 4 1 roll exch\n");
        else if (kp == 2) {
            fprintf(fp, "dup 2 div %.0f add neg exch 3 2 roll ", ca*0.35);
            fprintf(fp, "dup 2 div %.0f sub neg 4 1 roll exch\n", sa*0.35);
        }
        fprintf(fp, " %.0f add exch %.0f add exch\n", sa*0.5,ca*0.5);
        fprintf(fp, " %.0f dup 4 1 roll neg", sa*1.25);
        fprintf(fp, " %.0f dup neg 5 1 roll\n", ca*1.25);
        if (kp == 0)
            fprintf(fp, " %.0f neg %.0f neg\n", (ca-sa)*0.25,(ca+sa)*0.25);
        else {
            fprintf(fp, " 8 7 roll dup 9 1 roll %.0f sub", (ca-sa)*0.25);
            fprintf(fp, " 8 7 roll dup 9 1 roll %.0f sub\n", (ca+sa)*0.25);
        }
        fprintf(fp, "N %d %d M", ixp,iyp);
        fprintf(fp, " rmoveto rlineto rlineto rlineto closepath\n");
        if (bgcol > 0) {
            r = bgcol/0x10000; g = (bgcol/256)%256; b = bgcol%256;
            fprintf(fp, " %.3f %.3f %.3f RGB fill\n", r/255.,g/255.,b/255.);
        }
        else fprintf(fp, " %.3f T fill\n", -bgcol/255.);
    }
    fprintf(fp, "N %d %d M", ixp,iyp);
    if (kp != 0) fprintf(fp, " rmoveto");
    if (txcol > 0) {
        r = txcol/0x10000; g = (txcol/256)%256; b = txcol%256;
        fprintf(fp, " %.3f %.3f %.3f RGB show\n", r/255.,g/255.,b/255.);
    }
    else fprintf(fp, " %.3f T show\n", -txcol/255.);
    if (pen == 0) penatr(0, col, typ, wt);
    else newpen(pen);
    return(plot(wx,wy,3));
}

int pcstr(double xp, double yp, double chi, char *text, double ang, int ns)
{   int pen, col, typ, ixp, iyp, i, c;
    double wx, wy, wfac, wt, cb, sb; FILE *fp;
    if ((*text=='\0') || (ns==0)) return(0);
    if (where(&wx,&wy,&wfac) < 0)
        { fprintf(stderr, "pcstr: error at calling where\n"); return(-1); }
    pen = qpatr(0,&col,&typ,&wt); qpsfp(&fp);
    plot(xp,yp,3); qapos(&ixp,&iyp);
    chi *= (DPI/1.524) * wfac; cb = chi*cos(ang/RAD); sb = chi*sin(ang/RAD);
    fprintf(fp, "/Courier findfont\n");
    fprintf(fp, "[%.2f %.2f %.2f %.2f 0 0]", cb,sb,-sb,cb);
    fprintf(fp, " makefont setfont\n"); lfnt = 2;
    fputc('(', fp);
    for (i=1; ((i<=abs(ns)) && (*text!='\0')); i++,text++) {
        c = (unsigned char)*text;
        if ((c>=0x20) && (c<=0x7e)) {
            if (c == '\\') fprintf(fp, "\\\\");
            else if (c == '(') fprintf(fp, "\\(");
            else if (c == ')') fprintf(fp, "\\)");
            else fputc(c, fp);
        }
    }
    fputc(')', fp); fputc('\n', fp);
    if (ns < 0) fprintf(fp, " dup stringwidth neg exch neg exch\n");
    fprintf(fp, "N %d %d M", ixp,iyp);
    if (ns < 0) fprintf(fp, " rmoveto");
    fprintf(fp, " 0 T show\n");
    if (pen == 0) penatr(0, col, typ, wt);
    else newpen(pen);
    return(plot(wx,wy,3));
}

int pmark(int mark, double xc, double yc, double size, double thick, int mcol)
{   int pen, col, typ; double wx, wy, wfac, wt;
    float xp[5], yp[5]; double hs = size/2.;
    int n, i;
    if (where(&wx,&wy,&wfac) < 0)
        { fprintf(stderr, "pmark: error at calling where\n"); return(-1); }
    pen = qpatr(0,&col,&typ,&wt);

    if ((mark>=0) && (mark<=6)) {
        if (mark == 3) {
            xp[0] = xc; xp[1] = xc-hs; xp[2] = xc; xp[3] = xc+hs; 
            yp[0] = yc+hs; yp[1] = yc; yp[2] = yc-hs; yp[3] = yc; n = 4;
        }
        else if (mark == 4) {
            xp[0] = xc; xp[1] = xc-hs*0.866; xp[2] = xc+hs*0.866;
            yp[0] = yc+hs; yp[1] = yc-hs*0.5; yp[2] = yc-hs*0.5; n = 3;
        }
        else if (mark == 5) {
            xp[0] = xc; xp[1] = xc+hs*0.866; xp[2] = xc-hs*0.866;
            yp[0] = yc-hs; yp[1] = yc+hs*0.5; yp[2] = yc+hs*0.5; n = 3;
        }
        else if (mark == 6) {
            xp[0] = xc; xp[1] = xc-hs*0.588; xp[2] = xc+hs*0.951;
            xp[3] = xc-hs*0.951; xp[4] = xc+hs*0.588;
            yp[0] = yc+hs; yp[1] = yc-hs*0.809; yp[2] = yc+hs*0.309;
            yp[3] = yc+hs*0.309; yp[4] = yc-hs*0.809; n = 5;
        }
        if (thick == 0.) {
            dfpcol(1, mcol);
            if (mark == 0) paintc(xc, yc, hs);
            else if (mark == 1)
                { paintc(xc, yc, hs); dfpcol(1, -255); paintc(xc, yc, hs/3.); }
            else if (mark == 2) paintr(xc-hs, yc-hs, size, size);
            else paintp(xp, yp, n, 1);
        }
        else {
            penatr(0, mcol, 0, thick);
            if (mark == 0) wcirc(xc, yc, hs, 0.,360.);
            else if (mark == 1)
                { wcirc(xc, yc, hs, 0.,360.); wcirc(xc, yc, hs/3., 0.,360.); }
            else if (mark == 2) wrect(xc-hs, yc-hs, size, size);
            else {
                plot((double)xp[0], (double)yp[0], 3);
                for (i=1; i<n; i++) plot((double)xp[i], (double)yp[i], 2);
                clspath(0);
            }
        }
    }
    else if (mark == 7) {
        penatr(0, mcol, 0, thick);
        plot(xc-hs, yc-hs, 3); plot(xc+hs, yc+hs, 2);
        plot(xc-hs, yc+hs, 3); plot(xc+hs, yc-hs, 2);
        dfpcol(1, mcol);
        paintc(xc-hs*0.84, yc, hs*0.16); paintc(xc+hs*0.84, yc, hs*0.16);
        paintc(xc, yc-hs*0.84, hs*0.16); paintc(xc, yc+hs*0.84, hs*0.16);
    }
    else if (mark == 8) {
        penatr(0, mcol, 0, thick);
        plot(xc, yc-hs, 3); plot(xc, yc+hs, 2);
        plot(xc-hs, yc, 3); plot(xc+hs, yc, 2);
    }
    else if (mark == 9) {
        penatr(0, mcol, 0, thick);
        plot(xc-hs, yc-hs, 3); plot(xc+hs, yc+hs, 2);
        plot(xc-hs, yc+hs, 3); plot(xc+hs, yc-hs, 2);
    }
    else { dfpcol(0, 0); paintc(xc, yc, hs); }

    if (pen == 0) penatr(0, col, typ, wt);
    else newpen(pen);
    return(plot(wx,wy,3));
}

/*******************************************/
/*   FORTRAN Language Interface Routines   */
/*******************************************/

void lstyle_(char *f, float *h, float *a, int *tcol, int *bcol, size_t ls)
{   char fnt[3]={'\0', '\0', '\0'}; int i;
    for (i=0; i<3; i++) { if (i<ls) fnt[i]=*f++; }
    lstyle(fnt, (double)*h, (double)*a, *tcol, *bcol);
}

void ptext_(char *text, int *ltxt, float *xp, float *yp, int *kp)
{ if (ptext(text, *ltxt, (double)*xp, (double)*yp, *kp) < 0) exit(1); }

void pcstr_(float *xp, float *yp, float *chi, char *text, float *ang, int *ns)
{ if (pcstr((double)*xp, (double)*yp,
            (double)*chi, text, (double)*ang, *ns) < 0) exit(1); }

void pmark_(int *mark, float *xc, float *yc, float *sz, float *th, int *mcol)
{   pmark(*mark, (double)*xc, (double)*yc, (double)*sz, (double)*th, *mcol); }