(****************************************************************************)
(***                                                                      ***)
(*** First I must apologize for the sloppiness of this code.  :)  I did   ***)
(*** it late one night when someone asked me for it in the AD&D echo.     ***)
(*** I wouldn't have included the source code if it wasn't as small as it ***)
(*** is.  I really hope this helps someone's game and make it faster.     ***)
(*** That's the basic idea for all of my programs.  In this ZIP, you will ***)
(*** find there are 2 files: CHAR.PAS (pascal source code), and CHAR.EXE  ***)
(*** (basic executable program).                                          ***)
(***    Since this is the first version of the program, I would appreciate***)
(*** it if you would send me mail in the AD&D echo with all of your       ***)
(*** comments, questions, suggestions, and bug reports.  I hope to inprove***)
(*** this to YOUR tastes.  Happy gaming!                                  ***)
(***                                                                      ***)
(*** Dan Vanderboom                                                       ***)
(***                                                                      ***)
(****************************************************************************)

Program CharMaker;

Uses TpCrt,TpString,TpPick,DVRandom;

Var
   Choice:Word;
   Race,Class:Integer;
   MinAttr:Array[1..6] Of Integer;
   MaxAttr:Array[1..6] Of Integer;
   Attr:Array[1..6] Of Integer;
   Age:Integer;
   T:Integer;
   F:Text;
   Cas:String[30];
   Created:Boolean;

Const
   WindowCol:PickColorArray = (15,12,0,13,15,15);

Procedure NewSpace;
Var
   I:Integer;
Begin
   GotoXy(1,6);
   For I := 1 To 10 Do WriteLn;
End;

Procedure Strength;
Begin
   Write(F,'Str: ',Attr[1]);
   If Attr[1] < 10 Then Write(F,'  ') Else Write(F,' ');

   Write(F,'Hit Prob: ');
   T := 0;
   Case Attr[1] Of
      2..3:T := -3;
      4..5:T := -2;
      6..7:T := -1;
      17..18:T := 1;
   End;
   If T = 0 Then Write(F,'0');
   If T > 0 Then Write(F,'+',T);
   If T < 0 Then Write(F,T);

   Write(F,', Damage Adj: ');
   T := 0;
   Case Attr[1] Of
      2:T := -2;
      3..5:T := -1;
      16..17:T := 1;
      18:T := 3;
   End;
   If T = 0 Then Write(F,'0');
   If T > 0 Then Write(F,'+',T);
   If T < 0 Then Write(F,T);

   Write(F,', Open Doors: ');
   T := 0;
   Case Attr[1] Of
      2:T := 1;
      3:T := 2;
      4..5:T := 3;
      6..7:T := 4;
      8..9:T := 5;
      10..11:T := 6;
      12..13:T := 7;
      14..15:T := 8;
      16:T := 9;
      17:T := 10;
      18:T := 11;
   End;
   Write(F,T);

   Write(F,', Bend Bars/LG: ');
   T := 0;
   Case Attr[1] Of
      8..9:T := 1;
      10..11:T := 2;
      12..13:T := 4;
      14..15:T := 7;
      16:T := 10;
      17:T := 13;
      18:T := 16;
   End;
   WriteLn(F,T,'%');
End;

Procedure Dexterity;
Begin
   Write(F,'Dex: ',Attr[2]);
   If Attr[2] < 10 Then Write(F,'  ') Else Write(F,' ');

   Write(F,'Reaction Adj: ');
   T := 0;
   Case Attr[2] Of
      3:T := -3;
      4:T := -2;
      5:T := -1;
      16:T := 1;
      17..18:T := 2;
      19:T := 3;
   End;
   If T = 0 Then Write(F,'0');
   If T > 0 Then Write(F,'+',T);
   If T < 0 Then Write(F,T);

   Write(F,', Missile Attack Adj: ');
   If T = 0 Then Write(F,'0');
   If T > 0 Then Write(F,'+',T);
   If T < 0 Then Write(F,T);

   Write(F,', Defensive Adj: ');
   T := 0;
   Case Attr[2] Of
      3:T := 4;
      4:T := 3;
      5:T := 2;
      6:T := 1;
      15:T := -1;
      16:T := -2;
      17:T := -3;
      18..19:T := -4;
   End;
   If T = 0 Then WriteLn(F,'0');
   If T > 0 Then WriteLn(F,'+',T);
   If T < 0 Then WriteLn(F,T);
End;

Procedure Constitution;
Begin
   Write(F,'Con: ',Attr[3]);
   If Attr[3] < 10 Then Write(F,'  ') Else Write(F,' ');

   Write(F,'HP Adj: ');
   T := 2;
   Case Attr[3] Of
      2..3:T := -2;
      4..6:T := -1;
      7..14:T := 0;
      15:T := 1;
      16:T := 2;
      17:If Class In [1..3] Then T := 3;
      18:If Class In [1..3] Then T := 4;
      19:If Class In [1..3] Then T := 5;
   End;
   If T >= 1 Then Write(F,'+',T) Else Write(F,T);
   Write(F,', System Shock: ');
   T := 0;
   Case Attr[3] Of
      2:T := 20;
      3:T := 25;
      4:T := 30;
      5:T := 35;
      6:T := 40;
      7:T := 45;
      8:T := 50;
      9:T := 55;
      10:T := 60;
      11:T := 65;
      12:T := 70;
      13:T := 75;
      14:T := 88;
      15:T := 90;
      16:T := 95;
      17:T := 97;
      18:T := 99;
      19:T := 99;
   End;
   Write(F,T,'%');

   Write(F,', Resur Survival: ');
   T := 0;
   Case Attr[3] Of
      2:T := 35;
      3:T := 40;
      4:T := 45;
      5:T := 50;
      6:T := 55;
      7:T := 60;
      8:T := 65;
      9:T := 70;
      10:T := 75;
      11:T := 80;
      12:T := 85;
      13:T := 90;
      14:T := 92;
      15:T := 94;
      16:T := 96;
      17:T := 98;
      18:T := 100;
      19:T := 100;
   End;
   Write(F,T,'%');

   Write(F,', Poison Save: ');
   T := 0;
   Case Attr[3] Of
      2:T := -1;
      19:T := 1;
   End;
   If T >= 1 Then WriteLn(F,'+',T) Else WriteLn(F,T);
End;

Procedure Intelligence;
Begin
   Write(F,'Int: ',Attr[4]);
   If Attr[4] < 10 Then Write(F,'  ') Else Write(F,' ');

   Write(F,'Languages: ');
   T := 0;
   Case Attr[4] Of
      3..8:T := 1;
      9..11:T := 2;
      12,13:T := 3;
      14,15:T := 4;
      16:T := 5;
      17:T := 6;
      18:T := 7;
      19:T := 8;
   End;
   Write(F,T);

   Write(F,', Spell Level: ');
   T := 0;
   Case Attr[4] Of
      9:T := 4;
      10,11:T := 5;
      12,13:T := 6;
      14,15:T := 7;
      16,17:T := 8;
      18,19:T := 9;
   End;
   Write(F,T,'th');

   Write(F,', Learn Spell: ');
   T := 0;
   Case Attr[4] Of
      9:T := 35;
      10:T := 40;
      11:T := 45;
      12:T := 50;
      13:T := 55;
      14:T := 60;
      15:T := 65;
      16:T := 70;
      17:T := 75;
      18:T := 85;
      19:T := 95;
   End;
   Write(F,T,'%');

   Write(F,', Max Spells/Level: ');
   T := 0;
   Case Attr[4] Of
      9:T := 6;
      10..12:T := 7;
      13,14:T := 9;
      15,16:T := 11;
      17:T := 14;
      18:T := 18;
      19:T := -1;
   End;
   If T > 0 Then WriteLn(F,T) Else WriteLn(F,'All');
End;

Procedure Wisdom;
Begin
   Write(F,'Wis: ',Attr[5]);
   If Attr[5] < 10 Then Write(F,'  ') Else Write(F,' ');

   Write(F,'Magic Defense Adj: ');
   T := 0;
   Case Attr[5] Of
      2:T := -4;
      3:T := -3;
      4:T := -2;
      5..7:T := -1;
      15:T := 1;
      16:T := 2;
      17:T := 3;
      18:T := 4;
   End;
   If T >= 1 Then Write(F,'+',T) Else Write(F);

   Write(F,', Bonus Spells: ');
   T := 0;
   Case Attr[5] Of
      13,14:T := 1;
      15,16:T := 2;
      17:T := 3;
      18:T := 4;
   End;
   Write(F,T);
   Case T Of
      1:Write(F,'st');
      2:Write(F,'nd');
      3:Write(F,'rd');
      4:Write(F,'th');
   End;

   Write(F,', Spell Failure: ');
   T := 0;
   Case Attr[5] Of
      2:T := 60;
      3:T := 50;
      4:T := 45;
      5:T := 40;
      6:T := 35;
      7:T := 30;
      8:T := 25;
      9:T := 20;
      10:T := 15;
      11:T := 10;
      12:T := 5;
   End;
   WriteLn(F,T,'%');
End;

Procedure Charisma;
Begin
   Write(F,'Cha: ',Attr[6]);
   If Attr[6] < 10 Then Write(F,'  ') Else Write(F,' ');

   Write(F,'Max # Henchmen: ');
   T := 1;
   Case Attr[6] Of
      5,6:T := 2;
      7,8:T := 3;
      9..11:T := 4;
      12,13:T := 5;
      14:T := 6;
      15:T := 7;
      16:T := 8;
      17:T := 10;
      18:T := 15;
   End;
   Write(F,T);

   Write(F,', Loyalty Base: ');
   T := 0;
   Case Attr[6] Of
      2:T := -7;
      3:T := -6;
      4:T := -5;
      5:T := -4;
      6:T := -3;
      7:T := -2;
      8:T := -1;
      14:T := 1;
      15:T := 3;
      16:T := 4;
      17:T := 6;
      18:T := 8;
   End;
   If T >= 1 Then Write(F,'+',T) Else Write(F,T);

   Write(F,', Reaction Adj: ');
   T := 0;
   Case Attr[6] Of
      2:T := -6;
      3:T := -5;
      4:T := -4;
      5:T := -3;
      6:T := -2;
      7:T := -1;
      13:T := 1;
      14:T := 2;
      15:T := 3;
      16:T := 5;
      17:T := 6;
      18:T := 7;
   End;
   If T >= 1 Then Write(F,'+',T) Else Write(F,T);
End;

Procedure SpecialAbilities;
Begin
   WriteLn(F);
   WriteLn(F,Center('Special Abilities',78));
   WriteLn(F,CharStr(#205,78));
   WriteLn(F);
   Case Race Of
      2:; { Elf }                  (* Not done here yet... *)
      3:; { Half-Elf }
      4:; { Halfling }
      5:; { Dwarf }
      6:; { Gnome }
   End;
End;

Procedure Misc;
Begin
   WriteLn(F);
   WriteLn(F,Center('Weapons',78));
   WriteLn(F,'    Name             ROF    Weight      Damage      Range    Location');
   WriteLn(F,CharStr(#205,78));
   WriteLn(F);
   WriteLn(F);
   WriteLn(F,Center('Armor',78));
   WriteLn(F,'    Name           AC       Weight');
   WriteLn(F,CharStr(#205,78));
   WriteLn(F);
   WriteLn(F);
   WriteLn(F,Center('Magical Items',78));
   WriteLn(F,'    Name                 Damage/Charges     Location');
   WriteLn(F,CharStr(#205,78));
   WriteLn(F);
   WriteLn(F);
   WriteLn(F,Center('Micellaneous Equipment',78));
   WriteLn(F,'    Item           Weight    Location         Other');
   WriteLn(F,CharStr(#205,78));
   WriteLn(F);
   WriteLn(F);
   WriteLn(F,Center('Clothing',78));
   WriteLn(F,'    Item           Weight    Location         Description');
   WriteLn(F,CharStr(#205,78));
   WriteLn(F);
   WriteLn(F);
   WriteLn(F,Center('Livestock',78));
   WriteLn(F,'    Name       Type           THAC0   AC   ATT    DMG     HP    Movement');
   WriteLn(F,CharStr(#205,78));
   WriteLn(F);
   WriteLn(F);
   WriteLn(F,Center('Food',78));
   WriteLn(F,'    Item              Amount       Location');
   WriteLn(F,CharStr(#205,78));
   WriteLn(F);
   WriteLn(F);
   WriteLn(F,Center('Treasure',78));
   WriteLn(F,'    Type      Amount      Weight       Location');
   WriteLn(F,CharStr(#205,78));
   WriteLn(F);
   WriteLn(F);
End;

Procedure Create;
Var
   I,H1,H2:Integer;
   Per:Integer;
   HP:Integer;
   Height,Weight:Integer;
   Male:Boolean;
   MF:Char;
   S,SL:Integer;
   Filename:String[14];
Begin
   Created := True;
   Write('(M)ale or (F)emale? ');
   MF := UpCase(ReadKey);
   If MF = 'F' Then Male := False Else Male := True;
   WriteLn;
   Write('Save as what filename? ');
   ReadLn(Filename);
   If Length(Filename) = 0 Then Halt;
   Assign(F,Filename);
   Rewrite(F);

   For I := 1 To 6 Do
   Begin
      MinAttr[I] := 3;
      MaxAttr[I] := 18;
   End;
   Case Race Of
      1:Begin
           Age := 15 + RandNum(1,4);
           Height := 60 + RandNum(2,20);
           If Not Male Then Dec(Height);
           If Male Then
              Weight := 140 + RandNum(6,60)
             Else
              Weight := 100 + RandNum(6,60);
        End;
      2:Begin
           MinAttr[2] := 6;
           MinAttr[3] := 7;
           MinAttr[4] := 8;
           MinAttr[6] := 8;
           Age := 100 + RandNum(5,30);
           If Male Then
           Begin
              Height := 55 + RandNum(1,10);
              Weight := 90 + RandNum(3,30);
           End
          Else
           Begin
              Height := 50 + RandNum(1,10);
              Weight := 70 + RandNum(3,30);
           End;
        End;
      3:Begin
           MinAttr[2] := 6;
           MinAttr[3] := 6;
           MinAttr[4] := 4;
           Age := 15 + RandNum(1,6);
           If Male Then
           Begin
              Height := 60 + RandNum(2,12);
              Weight := 110 + RandNum(3,39);
           End
          Else
           Begin
              Height := 58 + RandNum(2,12);
              Weight := 85 + RandNum(3,36);
           End;
        End;
      4:Begin
           MinAttr[1] := 7;
           MinAttr[2] := 7;
           MinAttr[3] := 10;
           MinAttr[4] := 6;
           MaxAttr[5] := 17;
           Age := 20 + RandNum(3,12);
           If Male Then
           Begin
              Height := 32 + RandNum(2,16);
              Weight := 52 + RandNum(5,20);
           End
          Else
           Begin
              Height := 30 + RandNum(2,16);
              Weight := 48 + RandNum(5,20);
           End;
        End;
      5:Begin
           MinAttr[1] := 8;
           MinAttr[3] := 11;
           MaxAttr[2] := 17;
           MaxAttr[6] := 17;
           Age := 40 + RandNum(5,30);
           If Male Then
           Begin
              Height := 43 + RandNum(1,10);
              Weight := 130 + RandNum(4,40);
           End
          Else
           Begin
              Height := 41 + RandNum(1,10);
              Weight := 105 + RandNum(4,40);
           End;
        End;
      6:Begin
           MinAttr[1] := 6;
           MinAttr[3] := 8;
           MinAttr[4] := 6;
           Age := 60 + RandNum(3,36);
           If Male Then
           Begin
              Height := 38 + RandNum(1,6);
              Weight := 72 + RandNum(5,20);
           End
          Else
           Begin
              Height := 36 + RandNum(1,6);
              Weight := 68 + RandNum(5,20);
           End;
        End;
   End;
   Case Class Of
      1:Begin
           MinAttr[1] := 9;
           HP := RandNum(1,10);
        End;
      2:Begin
           MinAttr[1] := 12;
           If MinAttr[3] < 9 Then MinAttr[3] := 9;
           MinAttr[5] := 13;
           MinAttr[6] := 17;
           HP := RandNum(1,10);
        End;
      3:Begin
           MinAttr[1] := 13;
           MinAttr[2] := 13;
           If MinAttr[3] < 14 Then MinAttr[3] := 14;
           MinAttr[5] := 14;
           HP := RandNum(1,10);
        End;
      4,5:Begin
             MinAttr[4] := 9;
             HP := RandNum(1,4);
          End;
      6:Begin
           MinAttr[5] := 9;
           HP := RandNum(1,8);
        End;
      7:Begin
           MinAttr[5] := 12;
           MinAttr[6] := 15;
           HP := RandNum(1,8);
        End;
      8:Begin
           MinAttr[2] := 9;
           HP := RandNum(1,6);
        End;
      9:Begin
           MinAttr[2] := 12;
           MinAttr[4] := 13;
           MinAttr[6] := 15;
           HP := RandNum(1,6);
        End;
   End;
   For I := 1 To 6 Do Attr[I] := RandNum(MinAttr[I],MaxAttr[I]);
   Per := 0;
   For I := 1 To 6 Do Per := Per + Attr[I];
   Per := (Round(Per / 6) - 9);
   Cas := '';
   Case Per Of
      -9..-7:Cas := 'Must Be Dead!!!';
      -6..-5:Cas := 'Terrible!!';
      -4..-3:Cas := 'Pitiful!';
      -2..-1:Cas := 'Below Average';
      0:Cas := 'Average';
      1..2:Cas := 'Above Average';
      3..4:Cas := 'Excellent!';
      5..6:Cas := 'Superior!!';
      7..9:Cas := 'God-like!!!';
   End;
   H1 := Height Div 12;
   H2 := 12 - (Height Div 12);

   ClrScr;
   GotoXy(1,2);
   TextColor(15);
   WriteLn(F,'Player Name:                                Age: ',Age);
   WriteLn(F,'Character Name:                             Hair/Eye Color: ');
   WriteLn(F,'Social Status: Adventurer                   Height: ',H1,'''',H2,'"');
   Write(F,'Race/Class: ');
   SL := 0;
   Case Race Of
      1:Begin
           Write(F,'Human ');
           SL := 6;
        End;
      2:Begin
           Write(F,'Elven ');
           SL := 6;
        End;
      3:Begin
           Write(F,'Half-Elven ');
           SL := 11;
        End;
      4:Begin
           Write(F,'Halfling ');
           SL := 9;
        End;
      5:Begin
           Write(F,'Dwarven ');
           SL := 8;
        End;
      6:Begin
           Write(F,'Gnome ');
           SL := 6;
        End;
   End;
   Case Class Of
      1:Begin
           Write(F,'Fighter');
           Inc(SL,7);
        End;
      2:Begin
           Write(F,'Ranger');
           Inc(SL,6);
        End;
      3:Begin
           Write(F,'Paladin');
           Inc(SL,7);
        End;
      4:Begin
           Write(F,'Mage');
           Inc(SL,4);
        End;
      5:Begin
           Write(F,'Specialist');
           Inc(SL,10);
        End;
      6:Begin
           Write(F,'Cleric');
           Inc(SL,6);
        End;
      7:Begin
           Write(F,'Druid');
           Inc(SL,5);
        End;
      8:Begin
           Write(F,'Thief');
           Inc(SL,5);
        End;
      9:Begin
           Write(F,'Bard');
           Inc(SL,5);
        End;
   End;
   S := 33 - SL;
   For I := 1 To S-1 Do Write(F,' ');
   WriteLn(F,'Weight: ',Weight,' lbs.');

   WriteLn(F,'Level: 1');
   WriteLn(F,'Alignment: ');
   WriteLn(F);
   T := 2;
   Case Attr[3] Of
      2..3:T := -2;
      4..6:T := -1;
      7..14:T := 0;
      15:T := 1;
      16:T := 2;
      17:If Class In [1..3] Then T := 3;
      18:If Class In [1..3] Then T := 4;
      19:If Class In [1..3] Then T := 5;
   End;
   Write(F,'HP   : ',HP,'(',HP+T,')');
   If T <> 0 Then WriteLn(F,' (Constitution Bonus)') Else WriteLn(F);

   T := 0;
   Case Attr[1] Of
      2,3:T := -3;
      4..5:T := -2;
      6..7:T := -1;
      17..18:T := 1;
   End;
   If T <> 0 Then
      WriteLn(F,'THAC0: 20','(',20-T,') ','(Strength Bonus)')
     Else
      WriteLn(F,'THAC0: 20');

   S := 10;
   T := S;
   Case Attr[2] Of
      15:Dec(T);
      16:Dec(T,2);
      17:Dec(T,3);
      18..19:Dec(T,4);
   End;
   Write(F,'AC   : ',S);
   If T <> S Then WriteLn(F,'(',T,') (Dex Bonus)') Else WriteLn(F);
   WriteLn(F,'XP   : 0');

   WriteLn(F,'Attacks: 1');
   WriteLn(F);

   Strength;
   Dexterity;
   Constitution;
   Intelligence;
   Wisdom;
   Charisma;
   WriteLn(F);
   WriteLn(F);
   Write(F,'Languages: Common');
   Case Race Of
      1:WriteLn(F,'.');
      2:WriteLn(F,' and Elven.');
      3:WriteLn(F,' and Half-Elven.');
      4:WriteLn(F,' and Halfling.');
      5:WriteLn(F,' and Dwarven.');
      6:WriteLn(F,' and Gnome.');
   End;
   SpecialAbilities;
   Misc;
   Close(F);
End;

Function ClassOp(Item:Word):String; Far;
Var
   A:Array[1..10] Of String[30];
Begin
   A[1] := 'Fighter';
   A[2] := 'Ranger';
   A[3] := 'Paladin';
   A[4] := 'Mage';
   A[5] := 'Specialist';
   A[6] := 'Cleric';
   A[7] := 'Druid';
   A[8] := 'Thief';
   A[9] := 'Bard';
   ClassOp := A[Item];
End;

Procedure ChooseClass;
Begin
   NewSpace;
   GotoXy(1,4);
   TextColor(11);
   Write(Center('Choose Class',80));
   Repeat
      If Not PickWindow(@ClassOp,9,35,6,46,16,True,WindowCol,'',Choice) Then Halt;
   Until Choice In [1..9];
   Class := Choice;
   Choice := 0;
End;

Function RaceOp(Item:Word):String; Far;
Var
   A:Array[1..6] Of String[8];
Begin
   A[1] := 'Human';
   A[2] := 'Elf';
   A[3] := 'Half-Elf';
   A[4] := 'Halfling';
   A[5] := 'Dwarf';
   A[6] := 'Gnome';
   RaceOp := A[Item];
End;

Procedure ChooseRace;
Begin
   NewSpace;
   GotoXy(1,4);
   TextColor(11);
   Write(Center('Choose Race',80));
   Repeat
      If Not PickWindow(@RaceOp,5,35,6,45,13,True,WindowCol,'',Choice) Then
         Halt;
   Until Choice In [1..6];
   Race := Choice;
   Choice := 0;
End;

Function MenuOp(Item:Word):String; Far;
Var
   A:Array[1..5] Of String[16];
Begin
   A[1] := 'Choose Race';
   A[2] := 'Choose Class';
   A[3] := 'Create Character';
   A[4] := 'Quit';
   MenuOp := A[Item];
End;

Procedure MainMenu;
Var
   Tmp:Word;
Begin
   Repeat
      NewSpace;
      If Not PickWindow(@MenuOp,4,31,6,49,11,True,WindowCol,'',Choice) Then Halt;
      Tmp := Choice;
      Choice := 0;
      Case Tmp Of
         1:ChooseRace;
         2:ChooseClass;
         3:Create;
      End;
   Until Tmp = 4;
End;

Begin
   ClrScr;
   WriteLn;
   TextColor(15);
   WriteLn(Center('Instant Character Creator',80));
   Created := False;
   MainMenu;
   WriteLn;
   TextColor(11);
   If Created Then
      WriteLn(Center('The character generated was rated as follows: '+Cas,80));
   WriteLn;
   TextColor(15);
   WriteLn(Center('Thank you for using Instant Character Creator',80));
   WriteLn(Center('by Dan Vanderboom!',80));
End.