home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Pascal / HISOFTPASCAL2,0-1.DMS / in.adf / HSPascal / AmigaDemos / SpeakersCorner.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-05-20  |  16.3 KB  |  495 lines
  1. {--------------------------------------------------------------------------
  2.  
  3.                      HighSpeed Pascal for the Amiga
  4.  
  5.                           SPEAKER'S CORNER DEMO
  6.  
  7.                   Programmed by Martin Eskildsen 1991
  8.  
  9.                   Copyright (c) 1991 by D-House I ApS
  10.                          All rights reserved
  11.  
  12.  
  13.   Version : Date (dd.mm.yy) : Comment
  14.   -----------------------------------
  15.     1.00 : 06.11.91 : First version
  16.     1.10 : 22.04.92 : Wait() fixed
  17.  
  18. --------------------------------------------------------------------------}
  19.  
  20. program SpeakersCorner;
  21.  
  22. uses Exec, Graphics, Intuition, Narrator, Speech, MenuUtil, Init;
  23.  
  24. const
  25.   version          = '1.00';    { Program's version }
  26.  
  27.   Rev              = 0;        { Library revision required }
  28.  
  29.   MaxInputLen      = 254;    { Number of characters in input buffer }
  30.  
  31.   InitMsg          = 'Speaker''s Corner';  { What to say at boot }
  32.  
  33.   InputSurroundBox : array [1..10] of integer = 
  34.                      (0,0, 325,0, 325,13, 0,13, 0,1);
  35.               { Box surrounding the input string }
  36.  
  37.   SpeakSurroundBox : array [1..10] of integer =
  38.                      (0,0, 195,0, 195,11, 0,11, 0,1);
  39.               { Box surrounding the "I want to speak!" gadget }
  40.  
  41.  
  42. type
  43.   InputStr    = string[MaxInputLen];    { The input buffer }
  44.  
  45. var
  46.   window      : pWindow;    { The program's window }
  47.   menu        : pMenu;        { The main menu }
  48.   input       : InputStr;    { The input buffer }
  49.   Undo        : InputStr;    { Undo buffer for input string }
  50.  
  51.   Font          : tTextAttr;    { The font used for all text }
  52.  
  53.   InputBorder   : tBorder;    { Setup for border around input box }
  54.   InputStrRec   : tStringInfo;    { Setup for the editable string field }
  55.   InputTextRec  : tIntuiText;    { Setup for the text connected to string field }
  56.   InputGadget   : tGadget;    { Assembly of the above }
  57.  
  58.   SpeakBorder   : tBorder;    { Border around "I want to speak!" gadget }
  59.   SpeakTextRec  : tIntuiText;    { "I want to speak!" }
  60.   SpeakGadget   : tGadget;    { Assembly of the above }
  61.  
  62.   PropTexts     : array [0..3] of tIntuiText;
  63.   PropImages    : array [0..3] of tImage;
  64.   PropInfo      : array [0..3] of tPropInfo;
  65.   PropGadgets   : array [0..3] of tGadget;
  66.  
  67.   AboutReq      : array [1..12] of tIntuiText;  { Texts for "About" requester }
  68.   AboutReqOk    : tIntuiText;                   { "Ok" in "About" requester }
  69.  
  70. { Set up all gadgets for main window }
  71. function CreateGadgets : pointer;
  72. var i : 0..3;
  73.  
  74.   { This func adjusts the input value n belonging to [min..max] to fit }
  75.   { the [0..65535] range for the proportional gadgets }
  76.   function MakeValue(n, min, max : System.Word) : System.Word;
  77.   begin
  78.     MakeValue := Trunc(65535 / (max-min) * n)
  79.   end;
  80.  
  81. begin
  82.   Undo := #0;
  83.  
  84. {--- Font information ---}
  85.   with Font do begin
  86.     ta_Name  := CstrConstPtr('topaz.font');
  87.     ta_Ysize := TOPAZ_EIGHTY;
  88.     ta_Style := 0;
  89.     ta_Flags := 0
  90.   end;
  91.  
  92. {--- Input string gadget setup ---}
  93.   with InputBorder do begin
  94.     LeftEdge   := -3;           { Position relative to gadget box }
  95.     TopEdge    := -3;
  96.     FrontPen   := 1;
  97.     BackPen    := 0;
  98.     DrawMode   := JAM1;
  99.     Count      := SizeOf(InputSurroundBox) div SizeOf(Integer) div 2;
  100.     XY         := @InputSurroundBox;
  101.     NextBorder := NIL
  102.   end;
  103.  
  104.   Input := InitMsg + #0;        { Put the intro message in the string gadget }
  105.  
  106.   with InputStrRec do begin
  107.     Buffer     := @Input[1];
  108.     UndoBuffer := @Undo[1];
  109.     BufferPos  := 0;
  110.     MaxChars   := MaxInputLen + 1;      { + 1 to hold #0 }
  111.     DispPos    := 0;
  112.     UndoPos    := 0;                    { The below are maintained by }
  113.     NumChars   := Length(Input);        { Intuition }
  114.     DispCount  := 0;
  115.     Cleft      := 0;
  116.     Ctop       := 0;
  117.     {$ifdef WORKBENCH_2}
  118.     Extension  := NIL;
  119.     {$else}
  120.     LayerPtr   := NIL;
  121.     {$endif}
  122.     LongInt_   := 0;
  123.     AltKeyMap  := NIL
  124.   end;
  125.  
  126.   with InputTextRec do begin
  127.     FrontPen  := 1;
  128.     BackPen   := 0;
  129.     DrawMode  := JAM1;
  130.     LeftEdge  := 0;              { Position relative to string gadget box }
  131.     TopEdge   := -8-3-2;
  132.     ITextFont := @Font;          { The font to use }
  133.     IText     := CstrConstPtr('Input String');
  134.     NextText  := NIL
  135.   end;
  136.  
  137.   with InputGadget do begin
  138.     NextGadget    := NIL;               { This gadget will be last in chain }
  139.     LeftEdge      := 8 + 3;
  140.     TopEdge       := 120;
  141.     Width         := 320;
  142.     Height        := 10;
  143.     Flags         := GADGHCOMP;
  144.     Activation    := RELVERIFY;
  145.     GadgetType    := STRGADGET;
  146.     GadgetRender  := @InputBorder;
  147.     SelectRender  := NIL;
  148.     GadgetText    := @InputTextRec;
  149.     MutualExclude := 0;
  150.     SpecialInfo   := @InputStrRec;
  151.     GadgetID      := 0;
  152.     UserData      := NIL
  153.   end;
  154.  
  155. {--- Speak gadget ---}
  156.   with SpeakBorder do begin
  157.     LeftEdge   := -1;
  158.     TopEdge    := -1;
  159.     FrontPen   := 1;
  160.     BackPen    := 0;
  161.     DrawMode   := JAM1;
  162.     Count      := SizeOf(SpeakSurroundBox) div SizeOf(Integer) div 2;
  163.     XY         := @SpeakSurroundBox;
  164.     NextBorder := NIL
  165.   end;
  166.  
  167.   with SpeakTextRec do begin
  168.     FrontPen  := 1;
  169.     BackPen   := 0;
  170.     DrawMode  := JAM1;
  171.     LeftEdge  := 1;
  172.     TopEdge   := 1;
  173.     ITextFont := @Font;
  174.     IText     := CstrConstPtr('I want to say something!');
  175.     NextText  := NIL
  176.   end;
  177.  
  178.   with SpeakGadget do begin
  179.     NextGadget    := @InputGadget;
  180.     LeftEdge      := 10;
  181.     TopEdge       := 150;
  182.     Width         := 192 + 1 + 1;
  183.     Height        := 8 + 1 + 1;
  184.     Flags         := GADGHCOMP;
  185.     Activation    := RELVERIFY or GADGIMMEDIATE;
  186.     GadgetType    := BOOLGADGET;
  187.     GadgetRender  := @SpeakBorder;
  188.     SelectRender  := NIL;
  189.     GadgetText    := @SpeakTextRec;
  190.     MutualExclude := 0;
  191.     SpecialInfo   := NIL;
  192.     GadgetID      := 0;
  193.     UserData      := NIL
  194.   end;
  195.  
  196. {--- Proportional Gadgets---}
  197.   with PropInfo[0] do begin
  198.     Flags      := AUTOKNOB or FREEHORIZ;
  199.     HorizPot   := 0;
  200.     VertPot    := 0;
  201.     HorizBody  := $1FFF;
  202.     VertBody   := $1FFF;
  203.     CWidth     := 0;                { Intuition property }
  204.     CHeight    := 0;
  205.     HPotRes    := 0;
  206.     VPotRes    := 0;
  207.     LeftBorder := 0;
  208.     TopBorder  := 0
  209.   end;
  210.  
  211.   with PropTexts[0] do begin
  212.     FrontPen  := 1;
  213.     BackPen   := 0;
  214.     DrawMode  := JAM1;
  215.     LeftEdge  := 0;
  216.     TopEdge   := -8-2;
  217.     ITextFont := @Font;
  218.     IText     := NIL;
  219.     NextText  := NIL
  220.   end;
  221.   
  222.   with PropImages[0] do begin           { Should NOT be initialized }
  223.   end;                                  { Intuition uses it }
  224.  
  225.   with PropGadgets[0] do begin
  226.     NextGadget    := @SpeakGadget;
  227.     LeftEdge      := 7;
  228.     TopEdge       := 23;
  229.     Width         := 327;
  230.     Height        := 10;
  231.     Flags         := GADGHCOMP or GADGIMAGE;
  232.     Activation    := RELVERIFY or GADGIMMEDIATE;
  233.     GadgetType    := PROPGADGET;
  234.     GadgetRender  := NIL;
  235.     SelectRender  := NIL;
  236.     GadgetText    := NIL;
  237.     MutualExclude := 0;
  238.     SpecialInfo   := NIL;
  239.     GadgetID      := 0;
  240.     UserData      := NIL
  241.   end;
  242.  
  243.   for i := 0 to 3 do begin
  244.     PropGadgets[i] := PropGadgets[0];
  245.     PropImages [i] := PropImages [0];
  246.     PropTexts  [i] := PropTexts  [0];
  247.     PropInfo   [i] := PropInfo   [0];
  248.     with PropGadgets[i] do begin
  249.       if i > 0 then NextGadget := @PropGadgets[i-1];
  250.       TopEdge       := PropGadgets[0].TopEdge + i*22;
  251.       GadgetRender := @PropImages[i];
  252.       GadgetText   := @PropTexts [i];
  253.       SpecialInfo  := @PropInfo  [i]
  254.     end;
  255.     case i of
  256.       0 : begin
  257.             PropTexts[0].IText := CstrConstPtr('Sample Frequency');
  258.             PropInfo[0].HorizPot := MakeValue(DEFFREQ, MINFREQ, MAXFREQ)
  259.           end;
  260.       1 : begin
  261.             PropTexts[1].IText := CstrConstPtr('Rate');
  262.             PropInfo[1].HorizPot := MakeValue(DEFRATE, MINRATE, MAXRATE)
  263.           end;
  264.       2 : begin
  265.             PropTexts[2].IText := CstrConstPtr('Pitch');
  266.             PropInfo[2].HorizPot := MakeValue(DEFPITCH, MINPITCH, MAXPITCH)
  267.           end;
  268.       3 : begin
  269.             PropTexts[3].IText := CstrConstPtr('Volume');
  270.             PropInfo[3].HorizPot := MakeValue(DEFVOL, MINVOL, MAXVOL)
  271.           end
  272.     end;  { case }
  273.   end;
  274.  
  275.   CreateGadgets := @PropGadgets[3]
  276. end;
  277.  
  278. { Create a character-centred string. width is field width in characters }
  279. function Center(s : string; width : byte) : string;
  280. var i : byte;
  281. begin
  282.   for i := 1 to (width - length(s)) div 2 do s := ' ' + s;
  283.   Center := s
  284. end;
  285.  
  286. procedure SetUp;
  287. var
  288.   def : tNewWindow;     { Definition of window }
  289.   m   : pMenu;          { Temporary used when constructing menu }
  290.   i   : byte;
  291. begin
  292.  
  293.   { Open the used libraries }
  294.  
  295.   IntuitionBase := pIntuitionBase(OpenLibrary('intuition.library', Rev));
  296.   GfxBase       := pGfxBase      (OpenLibrary('graphics.library',  Rev));
  297.  
  298.   { First, define what the window should look like }
  299.  
  300.   with def do begin
  301.     LeftEdge      := 0;
  302.     TopEdge       := 0;
  303.     Width         := 340;
  304.     Height        := 170;
  305.     DetailPen     := -1;
  306.     BlockPen      := -1;
  307.     Title         := CStrConstPtr('Speaker''s Corner version ' + version);
  308.     Flags         := WINDOWCLOSE   or     { Add Close gadget, }
  309.                      WINDOWDEPTH   or     { depth arrangement gadgets }
  310.                      WINDOWDRAG    or     { and make it movable }
  311.                      SMART_REFRESH or     { Save window in RAM }
  312.                      ACTIVATE      or     { Activate it }
  313.                      NOCAREREFRESH;       { Don't wanna hear of refreshes! }
  314.     IDCMPFlags    := CLOSEWINDOW_  or     { But of user-clicks on Close }
  315.                      MENUPICK      or     { ...menu selections and }
  316.                      GADGETUP;            { ...released gadgets }
  317.     Type_         := WBENCHSCREEN;        { Put window on workbench screen }
  318.     FirstGadget   := CreateGadgets;       { The gadgets attached }
  319.     CheckMark     := NIL;                 { Same checkmark as usual }
  320.     Screen        := NIL;                 { Use workbench screen }
  321.     BitMap        := NIL;                 { No bitmap }
  322.     MinWidth      := Width;               { Dummies as we can't resize }
  323.     MinHeight     := Height;              { this window }
  324.     MaxWidth      := MinWidth;
  325.     MaxHeight     := MinHeight
  326.   end;
  327.  
  328.   { Then, construct the menus }
  329.  
  330.   InitMenu(menu, ' Info ');
  331.   AddItem (menu, ' About Speaker''s Corner... ', ITEMENABLED or HIGHCOMP, 0, #0);
  332.   AddItem (menu, '---------------------------', 0, 0, #0);
  333.   AddItem (menu, ' Exit',                        ITEMENABLED or HIGHCOMP or COMMSEQ, 0, 'E');
  334.  
  335.   AddMenu (m, menu, ' Sex ');
  336.   AddItem (m, '   Male       ', ITEMENABLED or HIGHCOMP or COMMSEQ or CHECKIT or CHECKED, $FFFE, 'M');
  337.   AddItem (m, '   Female     ', ITEMENABLED or HIGHCOMP or COMMSEQ or CHECKIT,            $FFFD, 'F');
  338.  
  339.   AddMenu (m, menu, ' Mode ');
  340.   AddItem (m, '   Human      ', ITEMENABLED or HIGHCOMP or COMMSEQ or CHECKIT or CHECKED, $FFFE, 'H');
  341.   AddItem (m, '   Robot      ', ITEMENABLED or HIGHCOMP or COMMSEQ or CHECKIT,            $FFFD, 'R');
  342.  
  343.   { Open the window }
  344.  
  345.   window := OpenWindow(@def);
  346.   if window = NIL then begin
  347.     writeln('Can''t open window');
  348.     halt(0)
  349.   end;
  350.  
  351.   if SetMenuStrip(window, menu) and OpenSpeech then { nothing } ;
  352.  
  353. {--- "About..." requester ---}
  354.   for i := 1 to 12 do                   { Create 12 lines }
  355.     with AboutReq[i] do begin
  356.       FrontPen  := 0;
  357.       BackPen   := 1;
  358.       DrawMode  := JAM1;
  359.       LeftEdge  := 6;
  360.       TopEdge   := i*10;
  361.       ITextFont := @Font;
  362.       if i < 12 then NextText  := @AboutReq[i+1] else NextText := NIL
  363.     end;
  364.  
  365.   { Then insert the text into all 12 lines }
  366.   AboutReq[ 1].IText := CstrConstPtr(Center('Speaker''s Corner version '+version, 36));
  367.   AboutReq[ 2].IText := CstrConstPtr(Center('', 36));
  368.   AboutReq[ 3].IText := CstrConstPtr(Center('a', 36));
  369.   AboutReq[ 4].IText := CstrConstPtr(Center('HighSpeed Pascal', 36));
  370.   AboutReq[ 5].IText := CstrConstPtr(Center('Demo Program', 36));
  371.   AboutReq[ 6].IText := CstrConstPtr(Center('', 36));
  372.   AboutReq[ 7].IText := CstrConstPtr(Center('Programming by', 36));
  373.   AboutReq[ 8].IText := CstrConstPtr(Center('Martin Eskildsen/D-House I', 36));
  374.   AboutReq[ 9].IText := CstrConstPtr(Center('', 36));
  375.   AboutReq[10].IText := CstrConstPtr(Center('You can contact HiSoft on', 36));
  376.   AboutReq[11].IText := CstrConstPtr(Center('Tel +44 525 718181', 36));
  377.   AboutReq[12].IText := CstrConstPtr(Center('Fax +44 525 713716', 36));
  378.  
  379.   with AboutReqOk do begin
  380.     FrontPen  := 0;
  381.     BackPen   := 1;
  382.     DrawMode  := JAM1;
  383.     LeftEdge  := 6;                     { Position relative to gadget }
  384.     TopEdge   := 3;
  385.     ITextFont := @Font;
  386.     IText     := CstrConstPtr('Ok');
  387.     NextText  := NIL
  388.   end;
  389.  
  390.   Say(InitMsg)                          { Say hi to the user }
  391.  
  392. end;
  393.  
  394. procedure GoodBye;
  395. begin
  396.   CloseSpeech;
  397.   ClearMenuStrip(window);
  398.   CloseWindow(window);
  399.   CloseLibrary(pLibrary(IntuitionBase));  { Close Intuition }
  400.   CloseLibrary(pLibrary(GfxBase))         { and Graphics }
  401. end;
  402.  
  403. procedure MakeInputPascal;
  404. begin
  405.   input[0] := #255;                     { Assume input = 255 chars for Pos }
  406.   input[0] := Chr(Pos(#0, input) - 1)   { But use only up to #0 }
  407. end;
  408.  
  409. procedure About;
  410. var bool : boolean;
  411. begin
  412.   bool := AutoRequest(window, @AboutReq[1], NIL, @AboutReqOk, 0, 0, 320, 155)
  413. end;
  414.  
  415. function MakeValue(n, low, high : System.Word) : System.Word;
  416. begin
  417.   MakeValue := Trunc( n / (65535 / (high - low)) )
  418. end;
  419.  
  420. procedure SelectLoop;
  421. var
  422.   dummy    : longint;
  423.   Imessage : pIntuiMessage;   { The messages sent to this program }
  424.   class    : integer;         { Message class }
  425.   code     : integer;         { Message code }
  426.   quit     : boolean;         { TRUE = done showing menu }
  427.   mNum     : integer;         { Menu number selected }
  428.   iNum     : integer;         { Item number selected }
  429.   address  : pointer;         { Objects' address }
  430.   ItemPtr  : pMenuItem;       { Pointer to a menu item structure }
  431.   TextPtr  : pIntuiText;      { Pointer to a IntuiText structure }
  432. begin
  433.   quit := FALSE;                           { Not done yet }
  434.   repeat
  435.     dummy := Wait(BitMask(window^.UserPort^.MP_SIGBIT));
  436.                                         { Wait for something to happen }
  437.  
  438.     Imessage := pIntuiMessage(GetMsg(window^.UserPort));
  439.                                         { Find out what }
  440.     while Imessage <> NIL do begin
  441.       class   := Imessage^.class;       { Save for later use }
  442.       code    := Imessage^.code;
  443.       address := Imessage^.IAddress;
  444.       ReplyMsg(pMessage(Imessage));     { Accept this message }
  445.       case class of
  446.         MENUPICK     : { The right mouse key was pressed }
  447.                        if code <> MENUNULL then begin  { Pointed at menu? }
  448.                          mNum := MenuNum(code);        { Title index }
  449.                          iNum := ItemNum(code);        { Item index }
  450.                          case mNum of
  451.                            0 : case iNum of            { Info menu }
  452.                                  0 : About;
  453.                                  2 : quit := TRUE
  454.                                end;
  455.                            1 : case iNum of            { Sex menu }
  456.                                  0 : SetSex(male);
  457.                                  1 : SetSex(female)
  458.                                end;
  459.                            2 : case iNum of            { Mode menu }
  460.                                  0 : SetMode(human);
  461.                                  1 : SetMode(robot)
  462.                                end
  463.                          end;
  464.                          if not ( (mNum = 0) and (iNum = 0) ) then begin
  465.                            ItemPtr := pMenuItem(ItemAddress(menu, code));
  466.                            TextPtr := pIntuiText(ItemPtr^.ItemFill);
  467.                            Say(RetrieveStr(TextPtr^.IText))
  468.                          end
  469.                        end;
  470.         GADGETUP     : if (address = @SpeakGadget) or (address = @InputGadget) then begin
  471.                          MakeInputPascal;
  472.                          Say(input)
  473.                        end else
  474.                        if address = @PropGadgets[0] then
  475.                          SetFrequency(MakeValue(PropInfo[0].HorizPot, MINFREQ, MAXFREQ)) else
  476.                        if address = @PropGadgets[1] then
  477.                          SetRate     (MakeValue(PropInfo[1].HorizPot, MINRATE, MAXRATE)) else
  478.                   if address = @PropGadgets[2] then
  479.                          SetPitch    (MakeValue(PropInfo[2].HorizPot, MINPITCH, MAXPITCH)) else
  480.                if address = @PropGadgets[3] then
  481.                          SetVolume   (MakeValue(PropInfo[3].HorizPot, MINVOL,  MAXVOL ))
  482.                        else writeln('Bad gadget! addr=',longint(address),' (dec.)');
  483.         CLOSEWINDOW_ : quit := TRUE
  484.       end;
  485.       Imessage := pIntuiMessage(GetMsg(window^.UserPort)) { Get next }
  486.     end;
  487.   until quit
  488. end;
  489.  
  490. begin
  491.   SetUp;
  492.   SelectLoop;
  493.   GoodBye
  494. end.
  495.