##
## This is file `putfile.',
## generated with the docstrip utility.
##
## The original source files were:
##
## coordsys.dtx (with options: `putfile')
##
##
## This is the coordsys and logsys packages
## Copyright 2000-06 by Mogens Lemvig Hansen,
## mlhansen@uniserve.com
##
## This program may be distributed and/or modified under the
## conditions of the LaTeX Project Public License, either version 1.3
## of this license or (at your option) any later version. The latest
## version of this license is in
## http://www.latex-project.org/lppl.txt
## and version 1.2 or later is part of all distributions of LaTeX
## version 2003/12/01 or later.
##
## This program consists of the files coordsys.dtx and coordsys.ins
##
putfile := proc(fn::{string, list(string), set(string)},
P::specfunc(anything, PLOT) )
option `Copyright 2000-06 by Mogens Lemvig Hansen`;
description "version 1.1";
local L, fns, i, V, scl, FH, ttl, pt, path, ext;
global StringTools;
L := [args[3..-1]];
if hasoption(L, 'scale', scl, 'L') then
scl := evalf(scl);
if not type(scl, ['numeric', 'numeric']) then
error "the scale option must be [numeric, numeric] but got %1",
scl;
fi;
else
scl := [1,1];
fi;
if L <> [] then
error "unknown options: %1", L;
fi;
L := map( `putfile/grabcurves`, [op(P)] );
if type(fn, 'string') then
path := map(StringTools:-FirstFromRight, ["\\", "/", ":"], fn);
path := max(op(path));
ext := StringTools:-FirstFromRight(".", fn[path+1..-1]);
if ext = 0 then
ext := ".tex";
fns := fn;
else
ext := fn[path+ext..-1];
fns := fn[1..-length(ext)-1]
fi;
if nops(L) = 1 then
fns := [fns];
else
fns := [ seq(cat(fns, i), i=1..nops(L)) ];
fi;
fns := map(cat, fns, ext);
else
fns := fn;
if nops(fns) <> nops(L) then
error "the number of filenames must match "
"the number of curves, "
"received %1 names but %2 curves.",
nops(fns), nops(L);
fi;
fi;
V := select(type, [op(P)], 'specfunc'('anything', 'VIEW'));
if nops(V) <> 1 then
V := ['DEFAULT', 'DEFAULT'];
else
V := [ op([1,1], V), op([1,2], V) ];
fi;
V := subs('DEFAULT'=Float(-infinity)..Float(infinity), V);
ttl := select(type, [op(P)], 'specfunc'('anything', 'TITLE'));
if nops(ttl) = 1 then
ttl := op([1,1], ttl);
ttl := StringTools:-SubstituteAll(ttl, "\n", "\n%% ");
fi;
L := map( `putfile/cleancurve`, L, V);
L := map2( map, u->[scl[1]*u[1], scl[2]*u[2]], L );
for i from 1 to nops(L) do try
FH := fopen(fns[i], 'WRITE', 'TEXT');
if type(ttl, 'string') then fprintf(FH, "%%%% %s\n", ttl) fi;
if scl <> [1,1] then fprintf(FH, "%% scaled %a\n", scl) fi;
V := [ map2(op, 1, L[i]), map2(op, 2, L[i]) ];
V := map( u-> min(op(u))..max(op(u)), V );
fprintf(FH, "%% horizontal range: %f .. %f\n", op(V[1]));
fprintf(FH, "%% vertical range: %f .. %f\n", op(V[2]));
for pt in L[i] do
fprintf(FH, "%f \t%f\n", op(pt));
od;
finally fclose(FH);
end try end do;
end;
`putfile/grabcurves` := proc(x)
option `Copyright 2000-06 by Mogens Lemvig Hansen`;
description "version 1.1";
local L;
if op(0, x) = 'CURVES' then
L := [ op(x) ];
L := select(type, L, 'list');
RETURN(op(L));
else
RETURN(NULL);
fi;
end;
`putfile/cleancurve` := proc(CC::list, V::list)
local C, B, pts, pt, m, i;
option `Copyright 2004-06 by Mogens Lemvig Hansen`;
description "version 1.1";
C := select(type, CC, ['numeric', 'numeric']);
if nops(C) < 1 then error "no numeric points in %1", C fi;
B := C[1];
for i from 2 to nops(C) do
if C[i] = C[i-1] then next fi;
pts := NULL;
if ( C[i-1][1] < lhs(V[1]) and C[i][1] > lhs(V[1]) )
or ( C[i-1][1] > lhs(V[1]) and C[i][1] < lhs(V[1]) ) then
m := ( C[i-1][2] - C[i][2] ) / ( C[i-1][1] - C[i][1] );
pt := lhs(V[1]);
pt := [ pt, m*(pt-C[i][1]) + C[i][2] ];
pts := pts, pt;
fi;
if ( C[i-1][1] < rhs(V[1]) and C[i][1] > rhs(V[1]) )
or ( C[i-1][1] > rhs(V[1]) and C[i][1] < rhs(V[1]) ) then
m := ( C[i-1][2] - C[i][2] ) / ( C[i-1][1] - C[i][1] );
pt := rhs(V[1]);
pt := [ pt, m*(pt-C[i][1]) + C[i][2] ];
pts := pts, pt;
fi;
if ( C[i-1][2] < lhs(V[2]) and C[i][2] > lhs(V[2]) )
or ( C[i-1][2] > lhs(V[2]) and C[i][2] < lhs(V[2]) ) then
m := ( C[i-1][1] - C[i][1] ) / ( C[i-1][2] - C[i][2] );
pt := lhs(V[2]);
pt := [ m*(pt-C[i][2]) + C[i][1], pt ];
pts := pts, pt;
fi;
if ( C[i-1][2] < rhs(V[2]) and C[i][2] > rhs(V[2]) )
or ( C[i-1][2] > rhs(V[2]) and C[i][2] < rhs(V[2]) ) then
m := ( C[i-1][1] - C[i][1] ) / ( C[i-1][2] - C[i][2] );
pt := rhs(V[2]);
pt := [ m*(pt-C[i][2]) + C[i][1], pt ];
pts := pts, pt;
fi;
pts := [pts];
if C[i-1][1] < C[i][1] then
pts := sort(pts, (u,v)->evalb(u[1]<v[1]));
elif C[i-1][1] > C[i][1] then
pts := sort(pts, (u,v)->evalb(u[1]>v[1]));
elif C[i-1][2] < C[i][2] then
pts := sort(pts, (u,v)->evalb(u[2]<v[2]));
elif C[i-1][2] > C[i][2] then
pts := sort(pts, (u,v)->evalb(u[2]>v[2]));
else
error "cannot happen";
fi;
B := B, op(pts), C[i];
od;
C := [B];
C := select( u->evalb(lhs(V[1])<=u[1] and u[1] <= rhs(V[1])), C);
C := select( u->evalb(lhs(V[2])<=u[2] and u[2] <= rhs(V[2])), C);
C;
end;
Generated by dwww version 1.15 on Thu May 23 08:03:57 CEST 2024.