home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 616.lha / Tapete / Tapete.mod < prev    next >
Text File  |  1992-03-03  |  12KB  |  473 lines
  1. (*
  2.  * :Program.      Tapete.mod
  3.  * :Author.       Fridtjof Siebert
  4.  * :Address.      Nobileweg 67, D-7000 Stuttgart 40
  5.  * :Shortcut.     [fbs]
  6.  * :Copyright.    FreeWare
  7.  * :Language.     Oberon-2
  8.  * :Translator.   Amiga Oberon Compiler V2.30 (inoffical version)
  9.  * :History. V1.0 02-Mar-92: first published version   [fbs]
  10.  * :Contents.     Tool to replace WBPattern by an arbitrary image
  11.  * :Usage.        Tapete <picture> [SAMECOLORS]
  12.  * :Remark.       Compile: 'Oberon -m Tapete', don't use small data model!
  13.  * :Remark.       Link:    'OLink -s Tapate OBJ LoadBody.o'
  14.  *
  15.  *
  16.  *
  17.  * Bitte nur mit großem Datenmodell:
  18.  *
  19.  * $IFNOT SmallData
  20.  *
  21.  *)
  22.  
  23. MODULE Tapete;
  24.  
  25. IMPORT Exec,
  26.        Graphics,
  27.        SYSTEM,
  28.        Dos,
  29.        OberonLib,
  30.        Strings,
  31.        IFFSupport,
  32.        Arguments;
  33.  
  34.  
  35. (*-------------------------------------------------------------------------*)
  36.  
  37.  
  38. TYPE
  39.   BP = PROCEDURE (rp{9}           : Graphics.RastPortPtr;
  40.                   mask{8}         : Graphics.PLANEPTR;
  41.                   xMin{0}         : INTEGER;
  42.                   yMin{1}         : INTEGER;
  43.                   xMax{2}         : INTEGER;
  44.                   yMax{3}         : INTEGER;
  45.                   bytecnt{4}      : INTEGER);
  46. (*
  47.  * Typ der BltPattern()-Prozedur
  48.  *)
  49.  
  50. VAR
  51.   OldBP: BP;
  52. (*
  53.  * Original BltPattern-Prozedur.
  54.  *)
  55.  
  56.  
  57. (*-------------------------------------------------------------------------*)
  58.  
  59.  
  60. TYPE
  61.   PatPlane = ARRAY 16 OF INTEGER;
  62.   PatPlanePtr = UNTRACED POINTER TO PatPlane;
  63. (*
  64.  * Typen für WB-AreaPattern
  65.  *)
  66.  
  67.   OldPat = STRUCT
  68.             weissnich: ARRAY 9 OF INTEGER;
  69.             pad: SHORTINT;
  70.             depth: SHORTINT;
  71.             data: ARRAY 8 OF PatPlane;   (* eigentlich: ARRAY depth OF PatPlane *)
  72.           END;
  73. (*
  74.  * Inhalt von ENV:sys/wb.pat
  75.  *)
  76.  
  77. CONST
  78.   IdentifyPattern =
  79.     PatPlane(0162FU,0F5A2U,0A18AU,00D66U,0FD1AU,07F9CU,0E15AU,05265U,
  80.              0C5C9U,06460U,0494FU,0E5DBU,0BC61U,0FF7BU,01510U,09432U);
  81. (*
  82.  * Durch Zufallszahlen erzeugtes Muster. Dieses wird verwendet, um die
  83.  * BltPattern-Aufrufe der Workbench zu identifizieren. Immer, wenn ein mit
  84.  * Rechteck diesem Muster gefüllt wird, wird stattdessen das Bild gezeichnet.
  85.  *)
  86.  
  87.  
  88. (*-------------------------------------------------------------------------*)
  89.  
  90.  
  91. VAR
  92.  
  93.   f: Dos.FileHandlePtr;      (* Generelles FileHandle zum Laden und Speichern.             *)
  94.  
  95.   oldwbpat, wbpat: OldPat;   (* Altes und neues ENV:sys/wb.pat                             *)
  96.   restoreWBPat: BOOLEAN;     (* Muß bei CLOSE ENV:sys/wb.pat neu geschrieben werden?       *)
  97.   WBPatSize: LONGINT;        (* Größe von oldwbpat                                         *)
  98.  
  99.   size: LONGINT;             (* verschieden verendet, größe von Dateien                    *)
  100.  
  101.   s,w: SYSTEM.ADDRESS;       (* Dummys für IFFSupport.ReadILBM()                           *)
  102.  
  103.   Image: Graphics.BitMapPtr; (* Geladenes Bild                                             *)
  104.  
  105.   i: INTEGER;                (* Durchwandern der Argumente, Farben und  Planes             *)
  106.  
  107.   arg,Pic: ARRAY 256 OF CHAR;(* Akutuelles Argument, Name des Bildes                       *)
  108.  
  109.   SameColors: BOOLEAN;       (* ist SAMECOLORS angegeben?                                  *)
  110.  
  111.   color: ARRAY 3 OF BYTE;    (* Zum Speichern der Farben                                   *)
  112.   ColorSize: LONGINT;        (* Zum Speichern von ENV:sys/palette.ilbm                     *)
  113.   CMAPSize: LONGINT;         (* dito                                                       *)
  114.  
  115.   OldPalette: ARRAY 512 OF CHAR; (* Vorheriger Inhalt von ENV:sys/palette.ilbm             *)
  116.   restorePalette: BOOLEAN;   (* Muß bei CLOSE ENV:sys/palette.ilbm neu geschrieben werden? *)
  117.   PaletteSize: LONGINT;      (* Gröe von OldPalette                                        *)
  118.  
  119.   port: Exec.MsgPortPtr;     (* MessagePort, zum Prüfen, ob Tapete schon gestartet wurde   *)
  120.  
  121.  
  122. (*-------------------------------------------------------------------------*)
  123.  
  124.  
  125. PROCEDURE FillWithImage(rp:Graphics.RastPortPtr; x,y,X,Y: INTEGER); (* $Debug- $StackChk- *)
  126. (*
  127.  * Zeichnet Image in rp in das Rechteck (x,y),(X,Y).
  128.  *
  129.  * Ist der Bereich größer als das Bild selbst, wird das Bild stückchenweise
  130.  * gezeichnet.
  131.  *
  132.  *)
  133.  
  134. VAR
  135.   width,height,w,h,startx,starty,Imagex,Imagey: INTEGER;
  136.  
  137. BEGIN
  138.   height := Y-y+1;
  139.   starty := y;
  140.   Imagey := starty MOD IFFSupport.NuScreen.height;
  141.  
  142.   WHILE height>0 DO
  143.  
  144.     h := IFFSupport.NuScreen.height - Imagey;
  145.     IF h>height THEN h := height END;
  146.  
  147.     width := X-x+1;
  148.     startx := x;
  149.     Imagex := startx MOD IFFSupport.NuScreen.width;
  150.  
  151.     WHILE width>0 DO
  152.  
  153.       w := IFFSupport.NuScreen.width - Imagex;
  154.       IF w>width THEN w := width END;
  155.  
  156.       Graphics.BltBitMapRastPort(Image,Imagex,Imagey,rp,startx,starty,w,h,0C0X);
  157.  
  158.       DEC(width,w);
  159.       INC(startx,w);
  160.       Imagex := 0;
  161.  
  162.     END;
  163.  
  164.     DEC(height,h);
  165.     INC(starty,h);
  166.     Imagey := 0;
  167.  
  168.   END;
  169. END FillWithImage;
  170.  
  171.  
  172. PROCEDURE CheckPtrn(p: PatPlanePtr): BOOLEAN; (* $StackChk- *)
  173. (*
  174.  * Prüft, ob p#NIL und p^ gleich dem IdentifyPattern ist.
  175.  * Dabei wird auch berücksichtigt, daß p^ evtl. vertikal
  176.  * verschoben wurde.
  177.  *)
  178.  
  179. VAR
  180.   y,i: INTEGER;
  181.  
  182. BEGIN
  183.   IF p#NIL THEN
  184.     y := 0;
  185.     WHILE (y<16) & (p[0]#IdentifyPattern[y]) DO INC(y) END;
  186.     IF y<16 THEN
  187.       i := 0;
  188.       WHILE IdentifyPattern[y]=p[i] DO
  189.         INC(i);
  190.         y := (y+1) MOD 16;
  191.         IF i=16 THEN RETURN TRUE END;
  192.       END;
  193.     END;
  194.   END;
  195.   RETURN FALSE;
  196. END CheckPtrn;
  197.  
  198.  
  199.  
  200. PROCEDURE NewBltPattern  (rp{9}           : Graphics.RastPortPtr;  (* $SaveRegs+ $StackChk- *)
  201.                           mask{8}         : Graphics.PLANEPTR;
  202.                           xMin{0}         : INTEGER;
  203.                           yMin{1}         : INTEGER;
  204.                           xMax{2}         : INTEGER;
  205.                           yMax{3}         : INTEGER;
  206.                           bytecnt{4}      : INTEGER);
  207. (*
  208.  * Neue, mit SetFunction aktivierte BltPattern()-Routine.
  209.  *)
  210.  
  211. VAR
  212.   xm,ym: INTEGER;
  213.  
  214. BEGIN
  215.   xm := xMin; ym := yMin;
  216.   IF CheckPtrn(rp.areaPtrn) THEN
  217.     FillWithImage(rp,xm,ym,xMax,yMax);
  218.   ELSE
  219.     OldBP(rp,mask,xm,ym,xMax,yMax,bytecnt);
  220.   END
  221. END NewBltPattern;  (* $StackChk+ $Debug= *)
  222.  
  223.  
  224. (*-------------------------------------------------------------------------*)
  225.  
  226.  
  227. BEGIN
  228.  
  229. (*
  230.  * 2.0 only:
  231.  *)
  232.  
  233.   IF Dos.dos.lib.version<37 THEN HALT(20) END;
  234.  
  235.  
  236. (*
  237.  * zunächst wird geprüft, ob wir schon einmal gestartet wurden:
  238.  *)
  239.  
  240.   Exec.Forbid;
  241.     port := Exec.FindPort("Tapeziertisch");
  242.     IF port#NIL THEN
  243.       Exec.Signal(port.sigTask,LONGSET{Dos.ctrlC});
  244.       port := NIL;
  245.       Exec.Permit;
  246.       Dos.PrintF("Signalled Tapete to quit.\n");
  247.       HALT(0);
  248.     ELSE
  249.       INCL(OberonLib.MemReqs,Exec.public);
  250.       NEW(port);
  251.       EXCL(OberonLib.MemReqs,Exec.public);
  252.       IF port=NIL THEN
  253.         Exec.Permit;
  254.         Dos.PrintF("Out of memory!\n");
  255.         HALT(20);
  256.       END;
  257.       port.node.name := SYSTEM.ADR("Tapeziertisch");
  258.       port.node.type := Exec.msgPort;
  259.       port.flags     := Exec.signal;
  260.       port.sigTask   := Exec.exec.thisTask;
  261.       Exec.AddPort(port)
  262.     END;
  263.   Exec.Permit;
  264.  
  265.  
  266. (*
  267.  * Nun werden die Argumente ausgewertet:
  268.  *)
  269.  
  270.   FOR i:=1 TO Arguments.NumArgs() DO
  271.  
  272.     Arguments.GetArg(i,arg);
  273.  
  274.     Strings.Upper(arg);
  275.     IF arg="SAMECOLORS" THEN
  276.  
  277.       SameColors := TRUE
  278.  
  279.     ELSE
  280.  
  281.       Arguments.GetArg(i,Pic);
  282.  
  283.     END;
  284.  
  285.   END;
  286.  
  287.   IF (Pic="") OR (Pic="?") THEN
  288.  
  289.     Dos.PrintF("Usage: Tapete <Picture> [SAMECOLORS]\n");
  290.     HALT(5);
  291.  
  292.   END;
  293.  
  294.  
  295. (*
  296.  * Das Bild wird geladen:
  297.  *)
  298.  
  299.   IF ~ IFFSupport.ReadILBM(Pic,{IFFSupport.usebmsize,IFFSupport.dontopen,IFFSupport.visible},s,w) THEN
  300.  
  301.     Dos.PrintF("Couldn't load %s!\n",SYSTEM.ADR(Pic));
  302.     HALT(20);
  303.  
  304.   END;
  305.   Image := IFFSupport.NuScreen.customBitMap;
  306.  
  307.  
  308. (*
  309.  * Neue Palette setzen:
  310.  *)
  311.  
  312.   IF ~ SameColors THEN
  313.  
  314.     f := Dos.Open("ENV:sys/palette.ilbm",Dos.oldFile);
  315.     IF f=NIL THEN Dos.PrintF("ENV:sys/palette.ilbm not found!\n"); HALT(20) END;
  316.  
  317.     PaletteSize := Dos.Read(f,OldPalette,SIZE(OldPalette));
  318.     IF ~ Dos.Close(f) OR (PaletteSize<=0) THEN
  319.       Dos.PrintF("Error Reading ENV:sys/palette.ilbm!\n");
  320.       HALT(20);
  321.     END;
  322.  
  323.     restorePalette := TRUE;
  324.  
  325.     f := Dos.Open("ENV:sys/palette.ilbm",Dos.newFile);
  326.     IF f=NIL THEN Dos.PrintF("Couldn't open ENV:sys/palete.ilbm!\n"); HALT(20) END;
  327.  
  328.     CMAPSize := 3*IFFSupport.IFFInfo.CMAP.colorCnt;
  329.     IF ODD(CMAPSize) THEN INC(CMAPSize) END;
  330.     ColorSize := CMAPSize + 56;
  331.  
  332.     size := Dos.Write(f,"FORM"   ,4) +
  333.             Dos.Write(f,ColorSize,4) +
  334.             Dos.Write(f,"ILBMBMHD"
  335.                         "\x00\x00\x00\x14\x00\x10\x00\x01\x00\x00\x00\x00\x04\x00\x00\x00"
  336.                         "\x00\x00\x0A\x0B\x01\x40\x00\xC8CMAP",36) +
  337.             Dos.Write(f,CMAPSize,4);
  338.     FOR i := 0 TO IFFSupport.IFFInfo.CMAP.colorCnt - 1 DO
  339.       color[0] := CHR(LONG(IFFSupport.IFFInfo.CMAP.red  [i])*16);
  340.       color[1] := CHR(LONG(IFFSupport.IFFInfo.CMAP.green[i])*16);
  341.       color[2] := CHR(LONG(IFFSupport.IFFInfo.CMAP.blue [i])*16);
  342.       INC(size,Dos.Write(f,color,3));
  343.     END;
  344.     IF ODD(IFFSupport.IFFInfo.CMAP.colorCnt) THEN
  345.       INC(size,Dos.Write(f,"\x00",1));
  346.     END;
  347.     INC(size,Dos.Write(f,"BODY\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00",16));
  348.  
  349.     IF ~ Dos.Close(f) OR (size#ColorSize+8) THEN
  350.       Dos.PrintF("Error writing ENV:sys/palette.ilbm!\n");
  351.       HALT(20);
  352.     END;
  353.  
  354.   END;
  355.  
  356.  
  357. (*
  358.  * Neue BltPattern()-Routine aktivieren:
  359.  *)
  360.  
  361.   OldBP := SYSTEM.VAL(BP,Exec.SetFunction(Graphics.gfx,-312,SYSTEM.VAL(Exec.PROC,NewBltPattern)));
  362.  
  363.  
  364. (*
  365.  * Altes ENV:sys/wb.pat laden:
  366.  *)
  367.  
  368.   f := Dos.Open("ENV:sys/wb.pat",Dos.oldFile);
  369.   IF f=NIL THEN Dos.PrintF("ENV:sys/wb.pat not found!\n"); HALT(20) END;
  370.  
  371.   WBPatSize := Dos.Read(f,wbpat,SIZE(wbpat));
  372.   IF ~ Dos.Close(f) OR (WBPatSize<52) THEN
  373.     Dos.PrintF("Error Reading ENV:sys/wb.pat!\n");
  374.     HALT(20);
  375.   END;
  376.   oldwbpat := wbpat;
  377.  
  378.  
  379. (*
  380.  * Neues ENV:sys/wb.pat speichern:
  381.  *)
  382.  
  383.   wbpat.data[0] := IdentifyPattern;
  384.   restoreWBPat := TRUE;
  385.  
  386.   f := Dos.Open("ENV:sys/wb.pat",Dos.newFile);
  387.   IF f=NIL THEN Dos.PrintF("Couldn't open ENV:sys/wb.pat!\n"); HALT(20) END;
  388.  
  389.   size := WBPatSize - Dos.Write(f,wbpat,WBPatSize);
  390.   IF ~ Dos.Close(f) OR (size#0) THEN
  391.     Dos.PrintF("Error writing ENV:sys/wb.pat!\n");
  392.     HALT(20);
  393.   END;
  394.  
  395.  
  396. (*
  397.  * Warten, bis man uns nicht mehr will:
  398.  *)
  399.  
  400.   REPEAT UNTIL Dos.ctrlC IN Exec.Wait(LONGSET{Dos.ctrlC});
  401.  
  402. CLOSE
  403.  
  404.  
  405. (*
  406.  * ENV:sys/palette.ilbm zurückschreiben:
  407.  *)
  408.  
  409.   IF restoreWBPat THEN
  410.     f := Dos.Open("ENV:sys/wb.pat",Dos.newFile);
  411.     IF f=NIL THEN
  412.       Dos.PrintF("Couldn't open ENV:sys/wb.pat!\n")
  413.     ELSE
  414.       DEC(WBPatSize,Dos.Write(f,oldwbpat,WBPatSize));
  415.       IF ~ Dos.Close(f) OR (WBPatSize#0) THEN
  416.         Dos.PrintF("Error writing ENV:sys/wb.pat!\n");
  417.       END;
  418.     END;
  419.   END;
  420.  
  421.  
  422. (*
  423.  * ENV:sys/wb.pat zurückschreiben:
  424.  *)
  425.  
  426.   IF restorePalette THEN
  427.     f := Dos.Open("ENV:sys/palette.ilbm",Dos.newFile);
  428.     IF f=NIL THEN
  429.       Dos.PrintF("Couldn't open ENV:sys/palete.ilbm!\n")
  430.     ELSE
  431.       DEC(PaletteSize,Dos.Write(f,OldPalette,PaletteSize));
  432.       IF ~ Dos.Close(f) OR (PaletteSize#0) THEN
  433.         Dos.PrintF("Error writing ENV:sys/palette.ilbm!\n");
  434.       END;
  435.     END;
  436.   END;
  437.  
  438.  
  439. (*
  440.  * BltPattern wieder auf alte Routine setzen.
  441.  *
  442.  * ACHTUNG: Hier wird nicht geprüft, ob ein anderes Programm unterdessen
  443.  *   BltPattern mit SetFunction() verändert hat. Ist dies der Fall, stürzt
  444.  *   die Maschine ab.
  445.  *)
  446.  
  447.   IF OldBP # NIL THEN
  448.     IF Exec.SetFunction(Graphics.gfx,-312,SYSTEM.VAL(Exec.PROC,OldBP))=NIL THEN END;
  449.   END;
  450.  
  451.  
  452. (*
  453.  * Speicher für Bild freigeben:
  454.  *)
  455.  
  456.   IF Image#NIL THEN
  457.     FOR i:=0 TO Image.depth-1 DO
  458.       Graphics.FreeRaster(Image.planes[i],IFFSupport.NuScreen.width,IFFSupport.NuScreen.height);
  459.     END;
  460.     DISPOSE(Image);
  461.   END;
  462.  
  463.  
  464. (*
  465.  * Port schließen:
  466.  *)
  467.  
  468.   IF port#NIL THEN Exec.RemPort(port) END;
  469.  
  470. END Tapete.
  471.  
  472. (* $END *)
  473.