home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 093.lha / Chaos / Sources / csave.mod < prev    next >
Encoding:
Modula Implementation  |  1986-11-21  |  4.4 KB  |  151 lines
  1. (* $V+, $R+ *)
  2. (*
  3.  
  4.     This module will save the current picture into an IFF
  5.     file.
  6.     
  7.     Created: 8/31/87 by Richie Bielak
  8.     
  9.     Modified:
  10.     
  11.     Copyright © 1987 by Richie Bielak
  12.     
  13.     This program can be freely copied, but please leave 
  14.     my name in. Thanks....Richie
  15.  
  16. *)
  17. IMPLEMENTATION MODULE ChaosSave;
  18.  
  19. FROM SYSTEM    IMPORT ADR, ADDRESS;
  20. FROM Intuition IMPORT ScreenPtr, WindowPtr, GadgetPtr, CloseWindow,
  21.            WindowFlagsSet, WindowFlags, IDCMPFlags, IDCMPFlagsSet, 
  22.            IntuiMessagePtr, StringInfoPtr, Selected, IntuiText,
  23.            GadgetActivation, GadgetActivationSet, ActivateGadget;
  24. FROM SimpleWindows IMPORT CreateWindow;
  25. FROM SimpleGadgets IMPORT BeginGadgetList, EndGadgetList, FreeGadgetList,
  26.                LastGadget, AddGadgetTextButton, AddGadgetString;
  27. FROM Ports     IMPORT WaitPort, ReplyMsg, GetMsg, MessagePtr;
  28. FROM ChaosUtil IMPORT InitTextItem;
  29. FROM AmigaDOS  IMPORT FileHandle, Open, Close, ModeNewFile;
  30. FROM Memory    IMPORT AllocMem, FreeMem, MemClear, MemReqSet;
  31. FROM PutPict   IMPORT PutPicture, IffErr;
  32. FROM ShowError IMPORT Error;
  33.  
  34. CONST
  35.   BuffSize = 24;
  36.  
  37. TYPE
  38.   SaveGadgets = (OKGad, CancelGad, StrGad);
  39.   buffer = ARRAY [0..BuffSize-1] OF CHAR;
  40.  
  41. VAR
  42.   buffp : POINTER TO buffer;
  43.   ftext : IntuiText;
  44.   LastFile : buffer;
  45.  
  46. (* ++++++++++++++++++++++++++++++++++++++++ *)
  47. PROCEDURE SetUpGadgetList () : GadgetPtr;
  48.   VAR sp : StringInfoPtr;
  49.   BEGIN
  50.     BeginGadgetList ();
  51.     AddGadgetTextButton (147, 60, ADR("  OK  "));
  52.     AddGadgetTextButton (20,  60, ADR("Cancel"));
  53.     AddGadgetString (20, 30, BuffSize-1, BuffSize, ADR(LastFile));
  54.     (* Set the activation for the string gadget, so *)
  55.     (* that we get a message when a return is hit.  *)
  56.     LastGadget^.Activation := GadgetActivationSet {RelVerify};
  57.     (* Get the address of the buffer *)
  58.     sp := LastGadget^.SpecialInfo;
  59.     buffp := sp^.Buffer;
  60.     (* Put some text next to the gadget *)
  61.     InitTextItem (ftext, ADR("File Name"), 0, -10);
  62.     LastGadget^.GadgetText := ADR(ftext);
  63.     RETURN EndGadgetList ();    
  64.   END SetUpGadgetList;
  65.  
  66. (* ++++++++++++++++++++++++++++++++++++++++ *)
  67. PROCEDURE WritePicture (sp : ScreenPtr; wp : WindowPtr);
  68.   VAR
  69.     f : FileHandle;
  70.     wbufp : ADDRESS;
  71.     err : BOOLEAN;
  72.   BEGIN
  73.     (* First open the file *)
  74.     f := Open (buffp, ModeNewFile);
  75.     IF f <> NIL THEN
  76.       (* Allocate a work buffer *)
  77.       wbufp := AllocMem (4096, MemReqSet {MemClear});
  78.       IF wbufp = NIL THEN
  79.         Error (sp,"Can't allocate work buffer!");
  80.         RETURN
  81.       END;
  82.       (* Write out the picture *)
  83.       WITH sp^ DO
  84.         err := PutPicture (f, RastPort.BitMap^, Width, Height, 
  85.                            ViewPort.ColorMap^.ColorTable, 
  86.                wbufp, 4096);
  87.       END;
  88.       IF err THEN
  89.         Error (sp, "Can't write picture!");
  90.       END;
  91.       FreeMem (wbufp, 4096);
  92.       (* Close the file *)
  93.       Close (f);
  94.     ELSE
  95.       Error (sp, "Can't open file!");
  96.     END; (* f <> NIL *)
  97.   END WritePicture;
  98.  
  99. (* ++++++++++++++++++++++++++++++++++++++++ *)
  100. PROCEDURE SavePicture (width, height : CARDINAL; sp : ScreenPtr);
  101.   VAR
  102.     wp       : WindowPtr;
  103.     GListPtr : GadgetPtr;
  104.     gptr     : GadgetPtr;
  105.     msgptr   : IntuiMessagePtr;
  106.     quit     : BOOLEAN;
  107.     class    : IDCMPFlagsSet;
  108.     save     : BOOLEAN;
  109.     succ     : BOOLEAN;
  110.   BEGIN
  111.     GListPtr := SetUpGadgetList ();
  112.     wp := CreateWindow (20, 12, 220, 75,
  113.                     IDCMPFlagsSet {GadgetUp, GadgetDown},
  114.                     WindowFlagsSet {Activate}, GListPtr, sp,
  115.                 ADR ("Save Picture..."));
  116.     (* Activate the string gadget. It's the last one in the list *)
  117.     succ := ActivateGadget (LastGadget^, wp^, NIL);
  118.     (* Process IDCMP messages *)
  119.     REPEAT
  120.       msgptr := WaitPort (wp^.UserPort^);
  121.       LOOP
  122.         msgptr := GetMsg (wp^.UserPort^);
  123.         IF msgptr = NIL THEN EXIT END;
  124.         class := msgptr^.Class; gptr := msgptr^.IAddress;        
  125.         ReplyMsg (MessagePtr (msgptr));
  126.     IF class <= IDCMPFlagsSet {GadgetDown, GadgetUp} THEN
  127.           quit := TRUE;
  128.           CASE SaveGadgets(gptr^.GadgetID) OF
  129.             StrGad, OKGad:
  130.                save := buffp^[0] <> 0C; 
  131.         |
  132.         CancelGad:
  133.           save := FALSE;
  134.           END;
  135.     END;
  136.       END; (* LOOP *)
  137.     UNTIL quit;
  138.     CloseWindow (wp^);
  139.     (* Must call "WritePicture" first, as "FreeGadgetList" *)
  140.     (* deallocates the string buffer.                      *)
  141.     IF save THEN  
  142.       LastFile := buffp^; 
  143.       WritePicture (sp, wp); 
  144.     END;
  145.     FreeGadgetList (GListPtr^);
  146.   END SavePicture;
  147.  
  148. BEGIN
  149.  LastFile := "";
  150. END ChaosSave.
  151.