JustifyMessage

From 40tude Dialog Wiki

Script justifies texts in outgoing messages and posts. Compiled and checked with 40tude Dialog 2.0.5.1

{
->     Type : 40tude Dialog Event script.
->     Name : JustifyMessage
->  Version : 1.0. (2003-08-27)
->   Author : Doktor (doktorlubicz <at> poczta <dot> onet <dot> pl)
->    Descr : Script justifies texts in outgoing messages and posts.
->            You should use monospace font to see effects.

->  If you want to add script:
->    1. Select option Settings->Scripting->Scripting...
->    2. Select 'Event scripts' page.
->    3. Select 'OnBeforeSendingMessage' item.
->    4. Select File->New script.
->    5. Paste this script code.
->    6. Compile and save script.

->  If you have any suggestions about script or if you found any
->  bug in it, contact me. Please put a word 'script' in email subject.

->  You can modify below options:
->  WrapLinesAfter - describes how many chars should be in one line
->  NoWrapIfSpaces - if there are more than X spaces between words
->                   in one line script does not justify this line
->                   (e.g. on the end of paragraph)
->  EnableOnGroups - describes on which groups script works
->                   separate newsgroups names by spaces
->                   if option is empty script works on all groups
->  EnableOnMails  - describes if script should modify email messages
->  JustifyQuoted  - describes if script should modify quoted lines
->  QuoteChars     - recognized quote chars
}

program OnBeforeSendingMessage;

const
  // Begin of OPTIONS
  WrapLinesAfter = 76;
  NoWrapIfSpaces = 4;

  EnableOnGroups = 'news.software.readers alt.pl.test';
  EnableOnMails  = false;

  JustifyQuoted  = true;
  QuoteChars = '>|';
  // End of OPTIONS

var
  Words : TStringList;

function CorrectGroup (Message : TStringList) : boolean;
  var
    p, lineNo, lineNews : integer;
    group, groupsAct, groupsAlw : string;
begin
  result := false;

  lineNews := - 1;
  lineNo := 0;
  while (Pos ('Newsgroups: ', Message.Strings [lineNo]) = 0) or (lineNo = Message.Count - 1) do
    lineNo := lineNo + 1;

  if (lineNo <> - 1) and (lineNo <> Message.Count - 1) then
    begin
      groupsAlw := EnableOnGroups;
      groupsAct := Copy (Message.Strings [lineNo], Length ('Newsgroups: ') + 1, 255);
      if groupsAlw = '' then result := true;

      repeat
        p := Pos (' ', groupsAlw);
        if p = 0 then p := 255;
        group := Copy (groupsAlw, 1, p - 1);
        if Pos (group, groupsAct) <> 0 then result := true;
        Delete (groupsAlw, 1, p);
      until (p = 255);
    end;

end;

function JustifyLine (line : string) : string;
  var
   i, p, spaceLeftCnt, txtSpaceCnt, wrdSpaceCnt, wrdInLength, txtOutLength, txtInLength : integer;
   spaces, quotes, oneWord : string;
   isQuote : boolean;
begin
  Words.Clear;

  quotes := '';
  txtOutLength := 0;
  repeat
    p := Pos (' ', line);
    if p = 0 then p := 255;
    oneWord := Copy (line, 1, p - 1);

    isQuote := false;
    for i := 1 to Length (QuoteChars) do
      if Pos (Copy (QuoteChars, i, 1), oneWord) <> 0
        then isQuote := true;

    if isQuote
      then quotes := quotes + oneWord
      else
        begin
          if (quotes <> '')
            then quotes := quotes + ' ';
          Words.Add (quotes + oneWord);
          txtOutLength := txtOutLength + Length (quotes + oneWord);
          quotes := '';
        end;

    Delete (line, 1, p);
    while Pos (' ', line) = 1 do
      Delete (line, 1, 1);
  until (p = 255);

  wrdInLength := 0;
  for i := 1 to Words.Count - 2 do
    wrdInLength := wrdInLength + Length (Words.Strings [i]);
  txtInLength := WrapLinesAfter - (txtOutLength - wrdInLength);

  txtSpaceCnt := txtInLength - wrdInLength;
  if Words.Count = 1 then wrdSpaceCnt := WrapLinesAfter - txtOutLength;
  if Words.Count = 2 then wrdSpaceCnt := txtInLength;
  if Words.Count > 2 then wrdSpaceCnt := txtSpaceCnt div (Words.Count - 1);
  spaceLeftCnt := txtSpaceCnt - wrdSpaceCnt * (Words.Count - 1);

  if wrdSpaceCnt >= NoWrapIfSpaces then
    begin
      wrdSpaceCnt := 1;
      spaceLeftCnt := 0;
    end;

  spaces := '';
  for i := 1 to wrdSpaceCnt do
    spaces := spaces + ' ';

  line := Words.Strings [0];
  for i := 1 to Words.Count - 2 do
    begin
      if spaceLeftCnt > 0
        then line := line + ' ';
      spaceLeftCnt := spaceLeftCnt - 1;
      line := line + spaces;
      line := line + Words.Strings [i];
    end;

  if Words.Count > 1
    then line := line + spaces + Words.Strings [Words.Count - 1];

  result := line;
end;

procedure JustifyMessage (var Message : TStringList);
  var
    line : string;
    isQuote, endOfMes, justQ : boolean;
    i, lineNo : integer;
begin
  justQ := JustifyQuoted;

  lineNo := 0;
  while Message.Strings [lineNo] <> '' do
    lineNo := lineNo + 1;
  lineNo := lineNo + 1;

  endOfMes := false;
  repeat
    line := Message.Strings [lineNo];

    if line = '-- '
      then endOfMes := true;
    if lineNo >= Message.Count - 1
      then endOfMes := true;

    if not endOfMes then
      begin
        if justQ
          then Message.Strings [lineNo] := JustifyLine (line)
          else
            begin
              isQuote := false;
              for i := 1 to Length (QuoteChars) do
                if Pos (Copy (QuoteChars, i, 1), line) <> 0
                  then isQuote := true;

              if not isQuote
                then Message.Strings [lineNo] := JustifyLine (line);
            end;
      end;

    lineNo := lineNo + 1;
  until (endOfMes);
end;

procedure Justify (var Message : TStringList; IsEmail : boolean);
  var JustifyMails : boolean;
begin
  JustifyMails := EnableOnMails;

  try
    Words := TStringList.Create;

    if IsEmail and JustifyMails
      then JustifyMessage (Message);
    if (not IsEmail) and CorrectGroup (Message)
      then JustifyMessage (Message);
  finally
    Words.Free;
  end;
end;

// *** MAIN PROGRAM ***

function OnBeforeSendingMessage
  (var Message : TStringlist; Servername : string; IsEmail : boolean) : boolean;
begin

  Justify (Message, IsEmail);

  result := true;

end;

begin
end.