📄 cpnex.pas
字号:
{*********************************************}
{ }
{ COMPONENT for MS DOS and MS WINDOWS }
{ }
{ Source code for Turbo Pascal 6.0 and }
{ Turbo Pasacal for Windows 1.0 compilers. }
{ }
{ (c) 1991, Roderic D. M. Page }
{ }
{*********************************************}
{$I CPDIR.INC}
{*
TO DO:
Be explicit about syntax errors, so user has better idea what to do.
Better documentation of in/out character status
*}
unit cpnex;
{*
Primitives for NEXUS file processing
3/1/91
NEXUS_OBJ provides basic routines for
processing a NEXUS file.
Requires an open stream.
Error trapping is done locally.
Error messages can be accessed
by clients.
5/2/91
'ENDBLOCK' added as a synonym of 'END'
5/9/91
Uses global error info in cperror
BM(NH)
26 Sep 1991 Bug in GetBlock fixed where the case of an
error in the "begin" part of a block
statement was not trapped.
11 Mar 1992 Following correspondence with David Maddison,
I've made the following changes:
Import command is now a standard command, I've
change FORMAT= to FILETYPE=.
4 Jun 1992 RANDOM command added. function ValueField added.
*}
interface
uses
cpstream, { i/o stream }
cperror, { errors }
cplex { lexical scanner }
{$IFDEF MSDOS}
;
{$ELSE}
,
cpheader, { control ids }
cpwcdial; { counter dialog }
{$ENDIF}
const
{ commands }
UNRECOGNIZED_CMD = 0;
{* = standard command/block }
{ NEXUS cmds }
LEAFLABELS_CMD = 1;
TRANSLATE_CMD = 2; {*}
TREE_CMD = 3; {*}
UTREE_CMD = 4; {*}
END_CMD = 5; {*}
BEGIN_CMD = 6; {*}
NLEAVES_CMD = 7;
NTREES_CMD = 8;
IMPORT_CMD = 9; {*}
FILE_CMD = 11; {*}
TITLE_CMD = 12; {*}
FILETYPE_CMD = 13; {*}
NTAX_CMD = 14; {*}
RANGE_CMD = 15;
DIMENSIONS_CMD = 16; {*}
TAXLABELS_CMD = 17; {*}
RANDOM_CMD = 18; {*}
MODEL_CMD = 19; {*}
SEED_CMD = 40; {*}
ROOTED_CMD = 41;
UNROOTED_CMD = 42;
ALL_CMD = 43; {*}
{ PAUP and MACCLADE data commands }
{ DATA/CHARACTERS block }
FORMAT_CMD = 44; {*}
OPTIONS_CMD = 45; {*}
CHARLABELS_CMD = 46; {*}
STATELABELS_CMD = 47; {*}
MATRIX_CMD = 48; {*}
{ ASSUMPTIONS block }
USERTYPE_CMD = 49; {*}
CHARSET_CMD = 50; {*}
TYPESET_CMD = 51; {*}
WTSET_CMD = 52; {*}
EXSET_CMD = 53; {*}
ANCSTATES_CMD = 54; {*}
{CODONS block }
CODPOSSET_CMD = 55; {*}
GENCODE_CMD = 56; {*}
GAP_CMD = 57;
MISSING_CMD = 58;
INTERLEAVE_CMD = 59;
EQUATE_CMD = 60;
DATATYPE_CMD = 61;
SYMBOLS_CMD = 62;
MATCHCHAR_CMD = 63;
LABELPOS_CMD = 64;
TRANSPOSE_CMD = 65;
RESPECTCASE_CMD = 66;
NCHAR_CMD = 67;
{ NEXUS blocks }
UNRECOGNIZED_BLK = 20;
PROFILE_BLK = 21;
TREES_BLK = 22; {*}
DISTRIBUTION_BLK = 23;
TAXA_BLK = 24; {*}
NOTES_BLK = 25; {*}
DATA_BLK = 26; {*}
ASSUMPTIONS_BLK = 27; {*}
CHARACTERS_BLK = 28; {*}
CODONS_BLK = 29; {*}
MACCLADE_BLK = 30; { MacClade only }
PAUP_BLK = 31; { PAUP only }
UNSUPPORTED_BLK = 32;
type
NEXUS_OBJ = object
Error,
Cmd,
Blk : integer;
L : LEXOBJ;
constructor Init (S:STREAMOBJ_PTR);
destructor Done;
function ALabel:string;
function ClassBlk:integer;
function ClassCmd:integer;virtual;
procedure GetBlock;
procedure GetCmd;
function IsNexusFile:Boolean;
function NexusError:integer;
function Posn:string;
function Scanner:LEXOBJ_PTR;
{$IFDEF debug}
procedure ShowBlock (var ofile:text);
procedure ShowCmd (var ofile:text);
{$ENDIF}
procedure SkipBlock;
procedure SkipCmd;
function StringCmd (UpCase:Boolean):string;
function StringField:string;
function SymbolField:char;
function ValueCmd:real;
function ValueField:real;
end;
implementation
{-----------------------------Init-----------------------------------------}
{ Initialise scanner }
constructor NEXUS_OBJ.Init (S:STREAMOBJ_PTR);
begin
L.Init(S);
Error := erOK;
Cmd := UNRECOGNIZED_CMD;
Blk := UNRECOGNIZED_BLK;
end;
{-----------------------------Done-----------------------------------------}
{ Update global availble ErrorRec }
destructor NEXUS_OBJ.Done;
begin
ErrorRec.InputError (Error, L.Token, L.f^.FilePosn^);
end;
{-----------------------------ALabel---------------------------------------}
{ Return the next token (expected to be a label). }
function NEXUS_OBJ.ALabel:string;
begin
L.GetNonSpaceToken;
if (L.tt = ttIDENTIFIER) or (L.tt = ttNUMBER) then
ALabel := L.Token
else Error := erSyntax;
end;
{-----------------------------ClassBlk-------------------------------------}
{ Return the NEXUS block corresponding to the current
token. Block is either:
unrecognized : not a NEXUS block
unsupported : NEXUS but not supported
a valid, supported NEXUS block.
}
function NEXUS_OBJ.ClassBlk:integer;
var
s: string;
i: integer;
ClassBlock:integer;
begin
s := L.UpCaseToken;
ClassBlock := UNRECOGNIZED_BLK;
case s[1] of
'P': if s = 'PAUP' then ClassBlock := PAUP_BLK;
'T': if (s = 'TREES') then
ClassBlock := TREES_BLK
else
if (s = 'TAXA') then
ClassBlock := TAXA_BLK;
'D': if s = 'DISTRIBUTION' then
ClassBlock := DISTRIBUTION_BLK
else
if (s = 'DATA') then
ClassBlock := DATA_BLK;
'N': if (s = 'NOTES') then ClassBlock := NOTES_BLK;
'M': if (s = 'MACCLADE') then ClassBlock := MACCLADE_BLK;
'C': if (s = 'CODONS') then
ClassBlock := CODONS_BLK
else
if (s = 'CHARACTERS') then
ClassBlock := CHARACTERS_BLK;
'A': if (s = 'ASSUMPTIONS') then ClassBlock := ASSUMPTIONS_BLK;
end;
(* { Flag any unsupported blocks }
if (ClassBlock in [ASSUMPTIONS_BLK, CHARACTERS_BLK, CODONS_BLK,
DATA_BLK, MACCLADE_BLK, NOTES_BLK, PAUP_BLK]) then
ClassBlock := UNSUPPORTED_BLK;*)
ClassBlk := ClassBlock;
end;
{-----------------------------ClassCmd-------------------------------------}
{ Return the NEXUS command corresponding to
the scanner's current token. }
function NEXUS_OBJ.ClassCmd:integer;
var
s: string;
i: integer;
c: integer;
begin
s := L.UpCaseToken;
c := UNRECOGNIZED_CMD;
if Length(s) < 2 then begin
Error := erBadCmd;
ClassCmd := c;
Exit;
end;
case s[1] of
'A': if s = 'ALL' then
c := ALL_CMD
else
if (s = 'ANCSTATES') then
c := ANCSTATES_CMD;
'B': if s = 'BEGIN' then c := BEGIN_CMD;
'C': case s[2] of
'O': if (s = 'CODPOSSET') then
c := CODPOSSET_CMD;
'H': if (s = 'CHARLABELS') then
c := CHARLABELS_CMD
else if (s = 'CHARSET') then
c := CHARSET_CMD;
end;
'D': if (s = 'DIMENSIONS') or (s = 'DIMENSION') then c := DIMENSIONS_CMD
else if (s = 'DATATYPE') then c := DATATYPE_CMD;
'E': case s[2] of
'N': if (s = 'END') or (s = 'ENDBLOCK') then
c := END_CMD;
'Q': if (s = 'EQUATE') then c := EQUATE_CMD;
'X': if (s = 'EXSET') then c := EXSET_CMD;
end;
'F': begin
case s[2] of
'I' : if s = 'FILE' then
c := FILE_CMD
else
if (s = 'FILETYPE') then
c := FILETYPE_CMD;
'O' : if (s ='FORMAT') then c := FORMAT_CMD;
end;
end;
'G': if (s = 'GENCODE') then c := GENCODE_CMD
else if (s = 'GAP') then c := GAP_CMD;
'I': if s = 'IMPORT' then c := IMPORT_CMD
else if (s = 'INTERLEAVE') then c := INTERLEAVE_CMD;
'L': if s = 'LEAFLABELS' then c := LEAFLABELS_CMD
else if (s = 'LABELPOS') then c := LABELPOS_CMD;
'M': case s[2] of
'O' : if (s = 'MODEL') then c := MODEL_CMD;
'A' : if (s = 'MATRIX') then
c := MATRIX_CMD
else if (s = 'MATCHCHAR') then c := MATCHCHAR_CMD;
'I' : if (s = 'MISSING') then c := MISSING_CMD;
end;
'N': case s[2] of
'C' : if (s = 'NCHAR') then c := NCHAR_CMD;
'L' : if s = 'NLEAVES' then c := NLEAVES_CMD;
'T' : if (s = 'NTREES') then
c := NTREES_CMD
else if (s = 'NTAX') then
c := NTAX_CMD;
end;
'O': if (s = 'OPTIONS') then c := OPTIONS_CMD;
'R': begin
case s[2] of
'A' : if (s = 'RANGE') then
c := RANGE_CMD
else
if (s = 'RANDOM') then
c := RANDOM_CMD;
'O' : if (s = 'ROOTED') then
c := ROOTED_CMD;
'E' : if (s = 'RESPECTCASE_CMD') then
c := RESPECTCASE_CMD;
end;
end;
'S': case s[2] of
'E': if (s = 'SEED') then c := SEED_CMD;
'T': if (s = 'STATELABELS') then c := STATELABELS_CMD;
'Y': if (s = 'SYMBOLS') then c := SYMBOLS_CMD;
end;
'T': begin
case s[2] of
'A': if (s = 'TAXLABELS') then c := TAXLABELS_CMD;
'R': case s[3] of
'A' : if s = 'TRANSLATE' then
c := TRANSLATE_CMD
else if (s = 'TRANSPOSE') then
c := TRANSPOSE_CMD;
'E' : if (s = 'TREE') then c := TREE_CMD
end;
'I': if s = 'TITLE' then c := TITLE_CMD;
'Y': if (s= 'TYPESET') then c := TYPESET_CMD;
end;
end;
'U': case s[2] of
'T' : if s = 'UTREE' then c := UTREE_CMD;
'N' : if (s = 'UNROOTED') then c := UNROOTED_CMD;
'S' : if (s = 'USERTYPE') then c := USERTYPE_CMD;
end;
'W': if (s = 'WTSET') then c := WTSET_CMD;
end;
if (c = UNRECOGNIZED_CMD) then
Error := erBadCmd;
ClassCmd := c;
end;
{-----------------------------GetBlock-------------------------------------}
{ Get the next block in the file
Token = this token
11 Mar 1992
Automatically skips unrecognized NEXUS blocks.
}
procedure NEXUS_OBJ.GetBlock;
type
STATES = (stBEGIN, stTYPE, stSEMI, stDONE, stQUIT);
var
st: STATES;
begin
st := stBEGIN;
while (st <> stDONE) and (st <> stQUIT) do begin
case st of
stBEGIN: begin
GetCmd;
if (Error = 0) then begin
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -