FreeWare Collection 2/FreeSoftwareCollection2pd199x-jp.img/ms_dos/rword/rword.pas

Pascal/Delphi Source File | 1990-06-14 | 6KB | 216 lines

(************************************************************************)
(*  RWord  1.4    Random Word Generator  でたらめ言葉発生器             *)
(*  Copyright  1989,90  Y.Fujisawa    藤沢 泰全                         *)
(*  Machine:    J-3100B,SS  MS-DOS 2.11, 3.10                           *)
(*  Compiler:   TURBO-PASCAL 5.5                                        *)
(*  History:                                                            *)
(*      89-03-03    1.0     新規作成                                    *)
(*      89-03-05    1.1     procedure ReadFile を変更した　             *)
(*      89-03-08    1.2     単語を 1..9 で指定するようにした            *)
(*      89-03-23    1.3     Heap 領域を使う。-n オプションを追加        *)
(*      90-05-13    1.4     Turbo-Pascal 5.5 を使用。                   *)
(*                          改行、スペースで繰り返し、その他で終了      *)
(************************************************************************)

program  RWord(input,output);
uses  Dos;

const
    WordLength = 60;        (* 単語の長さ（最大） *)
    DelimiterChar = '/';    (* 単語の最後の区切り *)
    CrChar = ^M;            (* 改行文字 *)
type
    WordAttrType = 1..9;
    WordPtr = ^WordRec;
    WordRec = record
                St: string[WordLength];     (* 単語 *)
                Attr: WordAttrType;         (* 属性 *)
                Next: WordPtr;              (* 次の単語へのポインター *)
            end;
    VocabRec = record
                Num: integer;       (* 単語数 *)
                Ptr: WordPtr;       (* 単語へのポインター *)
               end;

var
    Vocabulary: array[WordAttrType] of VocabRec;    (* 属性ごとの単語 *)


(* エコーなしで、キー入力 *)
function  ReadKey: char;
var
    Regs: Registers;
begin
    Regs.AH := $08;
    MsDos(Regs);
    ReadKey := Chr(Regs.AL);
end;  { ReadKey }


(* メッセージを表示する *)
procedure  WriteMessage;
begin
    Writeln('RWord Version 1.4  Date:1990-5-14  Copyright 1989,90 Y.Fujisawa');
    Writeln('Usage:  RWORD [-n] <FileName>       ( n: Repeat times )');
end;  { WriteMessage }


{$f+}
function  HeapErrorFunc(Size: word): integer;
{$f-}
begin
    Writeln('メモリーが足りませんよ (^_^;)');
    HeapErrorFunc := 0;
end;  { HeapErrorFunc }


(* 単語ファイルを読み込む *)
procedure  ReadFile(FileName: string);
var
    TextFile: text;
    LineCount: integer;
    Line: string;

    procedure  OpenFile;
    begin
        if Pos('.',FileName) = 0 then  FileName := FileName+'.RWD';
        Assign(TextFile,FileName);
        {$i-}  Reset(TextFile);  {$i+}
        if IOResult <> 0 then  begin
            Writeln('ファイルが見つかりませんよ (^_^;)');
            Halt;
        end;  { if }
    end;  { OpenFile }

    procedure  ReadLine;

        procedure  ErrorExit;
        begin
            Writeln(LineCount:3,' 行目がおかしいですよ (^_^;)');
            Writeln('-->',Line);
            Close(TextFile);
            Halt;
        end;   { ErrorExit }

        function  GetWordAttr(Ch: char): WordAttrType;
        begin
            case UpCase(Ch) of
                '1'..'9':   GetWordAttr := Ord(Ch)-Ord('0');
                'A' :       GetWordAttr := 1;
                'N' :       GetWordAttr := 2;
                else    ErrorExit;
            end;  { case }
        end;  { GetWordType }

    var
        p: byte;
        at: WordAttrType;
        NewWord: WordPtr;
    begin
        Readln(TextFile, Line);
        Inc(LineCount);
        p := Pos(DelimiterChar,Line);
        if (p > 0) and ( p < Length(Line) ) then  begin
            New(NewWord);
            at := GetWordAttr(Line[p+1]);
            with NewWord^ do  begin
                St := Copy(Line,1,p-1);
                Attr := at;
                with Vocabulary[at] do  begin
                    Next := Ptr;
                    Ptr := NewWord;
                    Inc(Num);
                end;  { with }
            end;  { with }
        end  { if }
        else  ErrorExit;
    end;  { ReadLine }

var
    i: integer;
begin
    LineCount := 0;
    for i := 1 to 9 do  begin
        with Vocabulary[i] do  begin
            Num := 0;
            Ptr := nil;
        end;  { with }
    end;  { for }
    OpenFile;
    while not Eof(TextFile) do ReadLine;
    Close(TextFile);
end;  { ReadFile }


(* 乱数で単語を組み合わせる *)
function  RandomWord: string;

    function Scan(Ptr: WordPtr; n: integer): string;
    var
        i: integer;
    begin
        for i := 1 to n-1 do  Ptr := Ptr^.Next;
        Scan := Ptr^.St;
    end;  { Scan }

var
    s: string;
    at: WordAttrType;
begin
    s := '';
    for at := 1 to 9 do  begin
        with Vocabulary[at] do  begin
            if Num > 0 then  s := s+Scan(Ptr,Random(Num)+1);
        end;  { with }
    end;  { for }
    RandomWord := s;
end;  { RandomWord }


(* 繰り返しの回数を得る *)
function  GetRepeat(St: string): integer;

    procedure  ErrorExit;
    begin
        Writeln('繰り返しの指定がおかしいですよ (^_^;)');
        Halt;
    end;  { ErrorExit }

var
    Num,Result: integer;
begin
    if St[1] = '-' then  begin
        Delete(St,1,1);
        Val(St,Num,Result);
        if Result = 0 then
            GetRepeat := Num
        else
            ErrorExit;
    end  { if }
    else  ErrorExit;
end;  { GetRepeat }


var
    RepeatTimes,i: integer;
begin
    HeapError := @HeapErrorFunc;
    Randomize;
    case ParamCount of
        1:  begin
                ReadFile(ParamStr(1));
                repeat
                    WriteLn;
                    Write(RandomWord);
                until  not(ReadKey in [CrChar,' ']);
            end;
        2:  begin
                RepeatTimes := GetRepeat(ParamStr(1));
                ReadFile(ParamStr(2));
                for i := 1 to RepeatTimes do  Writeln(RandomWord);
            end;
        else    WriteMessage;
    end;  { case }
end.