-- MakePuzzle.mesa 
--   Edited by Sweet, 21-Sep-82  9:59:19

DIRECTORY
  Ascii,
  Inline,
  IODefs,
  PressDefs,
  PressUtilities,
  Random,
  Segments,
  Storage,
  Streams,
  String;

MakePuzzle: PROGRAM
  IMPORTS Inline, IODefs, PressDefs, PressUtilities, Random, Segments, Storage, Streams, String =
  BEGIN OPEN PressDefs;

  pfdBody: PressFileDescriptor;
  pfd: POINTER TO PressFileDescriptor = @pfdBody;
  Mica: TYPE = CARDINAL;
  MBox: TYPE = RECORD [x,y,w,h: Mica];

  P3: Mica = PointsToMicas[3];
  M1: Mica = MicasPerInch;
  M12: Mica = MicasPerInch/2;
  M14: Mica = MicasPerInch/4;
  M34: Mica = (3*MicasPerInch)/4;
  M38: Mica = (3*MicasPerInch)/8;
  bw: Mica;

  PointsToMicas: PROC [points: CARDINAL] RETURNS [Mica] =
    {RETURN [Inline.LongDiv[Inline.LongMult[points, MicasPerInch],72]]};


  CenterChar: PROC [c: CHARACTER, box: POINTER TO MBox] =
    BEGIN
    w: Mica;
    ns: STRING _ [2];
    ns.length _ 1; ns[0] _ c;
    w _ CharWidth[c];
    PutText[pfd, ns, box.x + (box.w-w)/2, box.y + P3 + (box.h-CharHeight)/2];
    END;

  Sort: PUBLIC PROCEDURE [
      a: DESCRIPTOR FOR ARRAY OF UNSPECIFIED, 
      Greater: PROC[UNSPECIFIED, UNSPECIFIED] RETURNS [BOOLEAN]] =
    BEGIN
    n: CARDINAL = LENGTH[a];
    i: CARDINAL;
    temp: CARDINAL;
    SiftUp: PROC [l, u: CARDINAL] =
      BEGIN
      s: CARDINAL;
      key: CARDINAL _ a[l-1];
      DO
        s _ l*2;
        IF s > u THEN EXIT;
        IF s < u AND Greater[a[s+1-1], a[s-1]] THEN s _ s+1;
        IF Greater[key, a[s-1]] THEN EXIT;
        a[l-1] _ a[s-1];
        l _ s;
        ENDLOOP;
      a[l-1] _ key;
      END;
    FOR i DECREASING IN [2..n/2] DO SiftUp[i, n]; ENDLOOP;
    FOR i DECREASING IN [2..n] DO
      SiftUp[1, i];
      temp _ a[1-1];
      a[1-1] _ a[i-1];
      a[i-1] _ temp;
      ENDLOOP;
    END;

  iRandom: ARRAY [0..32) OF CARDINAL;
  jRandom: ARRAY [0..32) OF CARDINAL;

  RandomizeRows: PROC =
    BEGIN
    r:  ARRAY [0..32) OF CARDINAL;
    rGreater: PROC [x, y: CARDINAL] RETURNS [BOOLEAN] =
      {RETURN [r[x] > r[y]]};
    i: CARDINAL;
    FOR i IN [0..nRows) DO
      r[i] _ Random.InRange[0, 1000];
      iRandom[i] _ i;
      ENDLOOP;
    Sort[DESCRIPTOR[@iRandom, nRows], rGreater ];
    END;
      
  RandomizeColumns: PROC =
    BEGIN
    r:  ARRAY [0..32) OF CARDINAL;
    rGreater: PROC [x, y: CARDINAL] RETURNS [BOOLEAN] =
      {RETURN [r[x] > r[y]]};
    i: CARDINAL;
    FOR i IN [0..nCols) DO
      r[i] _ Random.InRange[0, 1000];
      jRandom[i] _ nCols-1-i;
      ENDLOOP;
    Sort[DESCRIPTOR[@jRandom, nCols], rGreater ];
    END;
      

  nRows, nCols: CARDINAL _ 20;
  textX, textY: Mica;
  
  ComputeMargins: PROC =
    BEGIN
    rMax, cMax: Mica;

    cMax _ (13*M1)/2*nCols;
    rMax _ (9*M1)/nRows;
    bw _ MIN [rMax, cMax, M38];

    bottomMargin _ 10*M1 - nRows*bw;
    leftMargin _ ((17*M1)/2 - nCols * bw)/2;
    END;

  Alpha: TYPE = CHARACTER ['a..'z];

-- from Gaines, Cryptanalysis
  CharWeight: ARRAY Alpha OF CARDINAL = [
--  a,   b,   c,   d,   e,   f,   g,   h,   i,   j,   k,   l,   m,
  805, 162, 320, 365,1231, 228, 161, 514, 718,  10,  52, 403, 225,
--  n,   o,   p,   q,   r,   s,   t,   u,   v,   w,   x,   y,   z
  719, 794, 229,  20, 603, 659, 959, 310,  93, 203,  20, 188,   9];

  totalWeight: CARDINAL;

  RandomChar: PROC RETURNS [ch: Alpha] =
    BEGIN
    choice: CARDINAL _ Random.InRange[1, totalWeight];
    FOR ch IN Alpha DO
      IF choice < CharWeight[ch] THEN {
	ch _ ch + ('A - 'a);
        RETURN};
      choice _ choice - CharWeight[ch];
      ENDLOOP;
    END;

  Mode: TYPE = {horiz, vert, slopedown, slopeup, revhoriz, revvert, revslopedown, revslopeup};
  modeWeight: ARRAY Mode OF CARDINAL _ [30, 20, 7, 7, 0, 0, 0, 0];
  totalmodeWeight: CARDINAL;

  RandomMode: PROC RETURNS [m: Mode] =
    BEGIN
    choice: CARDINAL _ Random.InRange[0, totalmodeWeight-1];
    FOR m IN Mode DO
      IF choice < modeWeight[m] THEN RETURN;
      choice _ choice - modeWeight[m];
      ENDLOOP;
    END;

  Match: PROC [s: STRING, r, c: CARDINAL, mode: Mode] RETURNS [BOOLEAN] =
    BEGIN
    j: CARDINAL;
    ch: CHARACTER;
    SELECT mode FROM
      horiz => {
	IF c + s.length >= nCols THEN RETURN[FALSE];
	FOR j IN [0..s.length) DO
	  IF (ch _ node[r][c+j]) # 0C AND ch # s[j] THEN RETURN[FALSE];
	  ENDLOOP;
	FOR j IN [0..s.length) DO node[r][c+j] _ s[j]; ENDLOOP;
	RETURN[TRUE]};
      vert => {
	IF r + s.length >= nRows THEN RETURN[FALSE];
	FOR j IN [0..s.length) DO
	  IF (ch _ node[r+j][c]) # 0C AND ch # s[j] THEN RETURN[FALSE];
	  ENDLOOP;
	FOR j IN [0..s.length) DO node[r+j][c] _ s[j]; ENDLOOP;
	RETURN[TRUE]};
      slopedown => {
	IF r + s.length >= nRows OR c + s.length >= nCols THEN RETURN[FALSE];
	FOR j IN [0..s.length) DO
	  IF (ch _ node[r+j][c+j]) # 0C AND ch # s[j] THEN RETURN[FALSE];
	  ENDLOOP;
	FOR j IN [0..s.length) DO node[r+j][c+j] _ s[j]; ENDLOOP;
	RETURN[TRUE]};
      slopeup => {
	IF r < s.length-1 OR c + s.length >= nCols THEN RETURN[FALSE];
	FOR j IN [0..s.length) DO
	  IF (ch _ node[r-j][c+j]) # 0C AND ch # s[j] THEN RETURN[FALSE];
	  ENDLOOP;
	FOR j IN [0..s.length) DO node[r-j][c+j] _ s[j]; ENDLOOP;
	RETURN[TRUE]};
      revhoriz => {
	IF c < s.length-1 THEN RETURN[FALSE];
	FOR j IN [0..s.length) DO
	  IF (ch _ node[r][c-j]) # 0C AND ch # s[j] THEN RETURN[FALSE];
	  ENDLOOP;
	FOR j IN [0..s.length) DO node[r][c-j] _ s[j]; ENDLOOP;
	RETURN[TRUE]};
      revvert => {
	IF r < s.length-1 THEN RETURN[FALSE];
	FOR j IN [0..s.length) DO
	  IF (ch _ node[r-j][c]) # 0C AND ch # s[j] THEN RETURN[FALSE];
	  ENDLOOP;
	FOR j IN [0..s.length) DO node[r-j][c] _ s[j]; ENDLOOP;
	RETURN[TRUE]};
      revslopedown => {
	IF r < s.length-1 OR c < s.length-1 THEN RETURN[FALSE];
	FOR j IN [0..s.length) DO
	  IF (ch _ node[r-j][c-j]) # 0C AND ch # s[j] THEN RETURN[FALSE];
	  ENDLOOP;
	FOR j IN [0..s.length) DO node[r-j][c-j] _ s[j]; ENDLOOP;
	RETURN[TRUE]};
      revslopeup => {
	IF r + s.length-1 >= nRows OR c < s.length-1 THEN RETURN[FALSE];
	FOR j IN [0..s.length) DO
	  IF (ch _ node[r+j][c-j]) # 0C AND ch # s[j] THEN RETURN[FALSE];
	  ENDLOOP;
	FOR j IN [0..s.length) DO node[r+j][c-j] _ s[j]; ENDLOOP;
	RETURN[TRUE]};
      ENDCASE => ERROR;
    END;

  AddWord: PROC [s: STRING] =
    BEGIN
    tried: ARRAY Mode OF BOOLEAN _ ALL[FALSE];
    key: STRING _ [40];
    i, j: CARDINAL;
    mode: Mode _ RandomMode[];
    AddInMode: PROC RETURNS [BOOLEAN] =
      BEGIN
      FOR r: CARDINAL IN [0..nRows) DO
	i _ iRandom[r];
	FOR c: CARDINAL IN [0..nCols) DO
	  j _ jRandom[c];
	  IF Match[key, i, j, mode] THEN RETURN[TRUE];
	  ENDLOOP;
	ENDLOOP;
      RETURN[FALSE];
      END;
    RandomizeRows[];
    RandomizeColumns[];
    FOR i IN [0..s.length) DO
      key[i] _ (IF s[i] IN ['a..'z] THEN s[i] + ('A - 'a) ELSE s[i]);
      ENDLOOP;
    key.length _ s.length;
    IF AddInMode[] THEN RETURN;
    mode _ vert; IF modeWeight[mode] # 0 AND AddInMode[] THEN RETURN;
    mode _ horiz; IF modeWeight[mode] # 0 AND AddInMode[] THEN RETURN;
    FOR mode IN [slopedown..revslopeup] DO
      IF modeWeight[mode] # 0 AND AddInMode[] THEN RETURN;
      ENDLOOP;
    SIGNAL CantDoIt;
    END;

  CantDoIt: SIGNAL = CODE;
    
  leftMargin, bottomMargin: Mica;


  node: POINTER TO ARRAY [0..32) OF PACKED ARRAY [0..32) OF CHARACTER;

  badData: SIGNAL = CODE;

  ReadDataFile: PROC [in: Streams.Handle] =
    BEGIN
    dataEnd: BOOLEAN _ FALSE;
    name: STRING = [40];
    number: STRING = [20];
    ch: CHARACTER;

    GetToken: PROC [token: STRING, spaceOK: BOOLEAN _ FALSE] =
      BEGIN ENABLE Streams.End[] => {dataEnd _ TRUE; GO TO done};
      token.length _ 0;
      IF dataEnd THEN RETURN;
      WHILE ch = Ascii.CR OR (~spaceOK AND ch = Ascii.SP) DO
        ch _ Streams.GetChar[in];
	ENDLOOP;
      IF ch = '; THEN {dataEnd _ TRUE; RETURN};
      WHILE (ch IN ['A..'Z]) OR (ch IN ['a..'z]) OR (ch IN ['0..'9])
         OR (spaceOK AND ch = Ascii.SP) DO
	String.AppendChar[token, ch];
        ch _ Streams.GetChar[in];
	ENDLOOP;
      IF token.length = 0 AND ~dataEnd THEN SIGNAL badData;
      IF ch = '; THEN dataEnd _ TRUE;
      EXITS
        done => RETURN;
      END;
    BEGIN
    ENABLE {
      badData => GO TO badFormat;
      String.StringBoundsFault => GO TO tooLong;
      String.InvalidNumber => GO TO badNumber};

    nRows _ nCols _ 0; nS _ 0;
    ch _ Streams.GetChar[in ! Streams.End[] => GO TO done];
    GetToken[number];
    nRows _ String.StringToDecimal[number];
    IF nRows > 32 THEN GO TO tooManyRows; 
    GetToken[number];
    nCols _ String.StringToDecimal[number];
    IF nCols > 32 THEN GO TO tooManyRows; 
    DO 
      GetToken[name, TRUE]; 
      IF name.length = 0 THEN EXIT;
      IF nS = 40 THEN GO TO tooManyStrings;
      input[nS] _ Storage.CopyString[name];
      sortedInput[nS] _ NoBlanks[name];
      nS _ nS + 1;
      ENDLOOP;
    EXITS
      tooLong => {
	IODefs.WriteString["token too long at "L];
	WriteLongNumber[Streams.GetIndex[in]]};
      tooManyRows => {
	IODefs.WriteString["max of 32 rows or columns"L]};
      tooManyStrings => {
	IODefs.WriteString["max of 40 words"L]};
      badNumber => {
	IODefs.WriteString["invalid number at "L];
	WriteLongNumber[Streams.GetIndex[in]]};
      badFormat => {
	IODefs.WriteString["invalid format at "L];
	WriteLongNumber[Streams.GetIndex[in]]};
      done => NULL;
    END;
    END;

  input, sortedInput: ARRAY [0..40] OF STRING;
  nS: CARDINAL _ 0;
  
  NoBlanks: PROC [s: STRING] RETURNS [ns: STRING] =
    BEGIN
    ns _ Storage.String[s.length];
    FOR i: CARDINAL IN [0..s.length) DO
      IF s[i] # Ascii.SP THEN String.AppendChar[ns, s[i]];
      ENDLOOP;
    END;

  FreeData: PROC = {
    FOR i: CARDINAL IN [0..nS) DO
      Storage.Free[input[i]]; Storage.Free[sortedInput[i]] ENDLOOP;
    nS _ 0};

  GenPuzzle: PROC =
    BEGIN
    ComputeMargins[];
    node^ _ ALL[ALL[0C]];
    FOR i: CARDINAL IN [0..nS) DO 
      AddWord[sortedInput[i]];
      ENDLOOP;
    END;

  GeneratePuzzle: PROC =
    BEGIN
    GenPuzzle[ ! CantDoIt => {IODefs.WriteChar['?]; RETRY}];
    IODefs.WriteChar['!];
    END;

  PrintWords: PROC =
    BEGIN
    Helvetica18[];
    textX _ M1;
    textY _ bottomMargin - M1;
    FOR i: CARDINAL IN [0..nS) DO 
      PutText[pfd, input[i], textX, textY];
      textY _ textY - CharHeight - P3;
      IF textY < M1 THEN 
        {textX _ textX + M1 + 3*M1/4; textY _ bottomMargin - M1};
      ENDLOOP;
    END;

  WriteLongNumber: PROC [ln: LONG CARDINAL] =
    BEGIN
    ls: STRING = [20];
    String.AppendLongNumber[ls, ln, 10];
    IODefs.WriteString[ls];
    END;

  CharHeight: Mica;
  CharWidth: POINTER TO ARRAY CHARACTER OF Mica;
  HCharWidth: ARRAY CHARACTER OF Mica;
  H14CharWidth: ARRAY CHARACTER OF Mica;

  Helvetica18: PROC =
    BEGIN
    SetFont[p: pfd, Name: "Helvetica", PointSize: 18, Face: 2];
    CharWidth _ @HCharWidth;
    CharHeight _ PointsToMicas[18];
    END;

  Helvetica14: PROC =
    BEGIN
    SetFont[p: pfd, Name: "Helvetica", PointSize: 14, Face: 2];
    CharWidth _ @HCharWidth;
    CharHeight _ PointsToMicas[14];
    END;

  DigestFonts: PROC =
    BEGIN
    [] _ PressUtilities.FindFontWidths[
      family: "Helvetica"L,
      points: 18,
      weight: bold,
      slope: regular,
      widths: LOOPHOLE[@HCharWidth]];
    [] _ PressUtilities.FindFontWidths[
      family: "Helvetica"L,
      points: 14,
      weight: bold,
      slope: regular,
      widths: LOOPHOLE[@H14CharWidth]];
    CharHeight _ PointsToMicas[18];
    END;
    
  WriteMatrix: PROC =
    BEGIN
    box: MBox _ [
      x: leftMargin, y: bottomMargin + (nRows-1)*bw, w: bw, h: bw];
    Helvetica18[];
    FOR r: CARDINAL IN [0..nRows) DO
      box.x _ leftMargin;
      FOR c: CARDINAL IN [0..nCols) DO
        ch: CHARACTER = node[r][c];
        CenterChar[(IF ch = 0C THEN RandomChar[] ELSE ch), @box];
        box.x _ box.x + bw;
        ENDLOOP;
      box.y _ box.y - bw;
      ENDLOOP;
    END;

  nP: CARDINAL;
  
  OneOrMore: PROC [inputFile: STRING] =
    BEGIN OPEN IODefs;
    Shorter: PROC [s1, s2: STRING] RETURNS [BOOLEAN] = {
      RETURN[s1.length < s2.length]};
    Alpha: PROC [s1, s2: STRING] RETURNS [BOOLEAN] = {
      RETURN[String.CompareStrings[s1, s2] > 0]};
    in: Streams.Handle _ NIL;
    node^ _ ALL[ALL[0C]];
    in _ Streams.NewStream [inputFile, Streams.Read !
      Segments.FileNameProblem[] => GO TO notFound];
    DO
      ReadDataFile[in];
      IF nRows = 0 THEN EXIT;
      Sort[DESCRIPTOR[BASE[sortedInput], nS], Shorter];
      THROUGH [0..nP) DO
        GeneratePuzzle[];
	Sort[DESCRIPTOR[BASE[input], nS], Alpha];
        PrintWords[];
        WriteMatrix[];
        WritePage[pfd];
        ENDLOOP;
      FreeData[];
      ENDLOOP;
    IF in # NIL THEN Streams.Destroy[in];
    EXITS
      notFound => {
	IODefs.WriteString[inputFile];
	IODefs.WriteLine[" not found."L]};
    END;
    
  Yes: PROC RETURNS [BOOLEAN] =
    BEGIN OPEN IODefs;
    SELECT ReadChar[] FROM
      'y, 'Y, CR => {WriteLine["yes"]; RETURN[TRUE]};
      ENDCASE => {WriteLine["no"]; RETURN[FALSE]};
    END;
    
  Driver: PROC =
    BEGIN OPEN IODefs;
    inputFile: STRING _ [40];
    ws: Streams.Handle;
    modeName: ARRAY Mode OF STRING _ [
      "left to right"L, "top to bottom"L, 
      "upper left to lower right"L, "lower left to upper right"L,
      "right to left"L, "bottom to top"L,
      "lower right to upper left"L, "upper right to lower left"L];
    node _ Storage.Words[32*32];
    WriteString["New weights? "];
    IF Yes[] THEN
      BEGIN
      ws _ Streams.NewStream["puzzle.weights"L, Streams.Write];
      FOR m: Mode IN Mode DO
        modeWeight[m] _ 0;
        WriteString[modeName[m]]; WriteString[": "L];
        modeWeight[m] _ ReadDecimal[ ! String.InvalidNumber => CONTINUE];
        Streams.PutWord[ws, modeWeight[m]];
        WriteChar[CR];
        ENDLOOP;
      Streams.Destroy[ws];
      END
    ELSE
      BEGIN
      ws _ Streams.NewStream["puzzle.weights"L, Streams.Read !
        Segments.FileNameProblem[] => GO TO noWeights];
      FOR m: Mode IN Mode DO
        modeWeight[m] _ Streams.GetWord[ws ! Streams.End[] => GO TO badWeights];
        ENDLOOP;
      Streams.Destroy[ws];
      END;
    
    Init[];
    DigestFonts[];
    InitPressFileDescriptor[pfd, "Puzzle.press"L];
    DO
      WriteString["Input data: "L];
      inputFile.length _ 0;
      ReadID[inputFile]; WriteChar[CR];
      IF inputFile.length = 0 THEN EXIT;
      WriteString["pages: "L];
      nP _ ReadDecimal[]; WriteChar[CR];
      OneOrMore[inputFile];
      ENDLOOP;
    ClosePressFile[pfd];
    Storage.FreeWords[node];
    EXITS
      noWeights => WriteLine["No weights available"L];
      badWeights => WriteLine["Insufficient weights"L];
    END;

  Init: PROC =
    BEGIN
    totalWeight _ 0;
    FOR a: Alpha IN Alpha DO 
      totalWeight _ totalWeight + CharWeight[a]; 
      ENDLOOP;
    totalmodeWeight _ 0;
    FOR m: Mode IN Mode DO 
      totalmodeWeight _ totalmodeWeight + modeWeight[m]; 
      ENDLOOP;
    END;
    
  Driver[];
  END.