11
$\begingroup$

I am trying to extract some graphics stored in PICT format from a Mathematica notebook, using a platform that doesn't support PICT. If I look at the .nb file in a plain text editor, or if I use FullForm, then I can see that the picture is stored as a GraphicsData head with a text string encoding the picture. It doesn't appear that the GraphicsData head uses Base64 or any other binary-to-text encoding that I know of off the top of my head, but I would like to be able to copy-and-paste the GraphicsData string and decode it manually. Is this possible? Does GraphicsData use a well-known encoding scheme?

$\endgroup$
3
  • $\begingroup$ Do you have an example notebook? $\endgroup$
    – ragfield
    May 15, 2012 at 1:17
  • $\begingroup$ @ragfield: Unfortunately, I don't have a good test case I can share. I've only encountered this problem with notebooks created on other people's computers. I can try to create a test case next time I have access, though. $\endgroup$ May 15, 2012 at 3:57
  • $\begingroup$ Some additional information about GraphicsData formats: mathematica.stackexchange.com/a/32886/280 $\endgroup$ Nov 8, 2013 at 7:21

2 Answers 2

12
$\begingroup$

I found an example on the web. Here is code that will convert the PICT data from the format stored in the notebook file into a .pict file that can be opened by an image viewer (e.g. Photoshop).

DecodePICT[data_String] := Module[
    {slash, backslash, zero, LF, CR, decode, codes, len, i},
    {slash, backslash, zero, LF, CR} = ToCharacterCode["/\\0\n\r"];
    decode[char_] := If[char == slash, backslash-zero, char-zero];
    len = Length[codes = ToCharacterCode[data]];
    i = 1;
    Join[Table[0,{512}], Last@Last@Reap@While[i <= len-1,
        Which[
            codes[[i]] == LF || codes[[i]] == CR,
            i++,
            codes[[i]] == backslash,
            i += 4,
            True,
            Sow@BitAnd[BitOr[
                BitShiftLeft[decode[codes[[i]]], 2],
                BitShiftRight[decode[codes[[i+1]]], 4]
            ], 255];
            i++;
            If[i <= len-1,
                Sow@BitAnd[BitOr[
                    BitShiftLeft[decode[codes[[i]]], 4],
                    BitShiftRight[decode[codes[[i+1]]], 2]
                ], 255]
            ];
            i++;
            If[i <= len-1,
                Sow@BitAnd[BitOr[
                    BitShiftLeft[decode[codes[[i]]], 6],
                    BitShiftRight[decode[codes[[i+1]]], 0]
                ], 255]
            ];
            i += 2;
        ]
    ]]
];

str = "0N801`0]05815@0A0_l<0?ooool0;@0000L0004E0000DP000000002Q0O@0hd=U
  K6aK8U`lG0eSKgEbHVEKM5mM83Xm80eLM51QLV5]IGAbJF=@K6md<dAKN`eLM2Pb
  :b1d84=_Le]fGBU3Kg=K<WIM;0eLM2Pb:b1d84=_Le]fGBUCJFiK<WIM;0eLM7@P
  DfU^FgIMOBakMR`P<2`P<R1@JGeM83]L3E`n8R`P8TU^L7Ed8R`=8219KF5WIE=Y
  NVD]?W/b<c8/83LeOB`=8219KF5WIDeQLVMYKW<]?W]k<2`P<7d/87/`;20`OGd/
  3B0PBFeQIfEBIFMYKfh]?W]k<2`P<Gd/87/`;20aOGeM000N01[oooooool00@0:
  00L0;@1B0AD0<@0602d0DP9203401`920582@P0J0000000002`01@R^0Te30003
  2:h0104000d0300^00@0o`0002/]4PiSKgEbHVEKM5mM83Xm8000:b0?4U1QLV5]
  IGAbJF=@K6md<dAKN`00:PlE:38[87@P@fmcFgIM:D=_Le/bMUd/000Z3aDX<R/P
  M213Kg=KMUdYDfU^Fc9fGB`002X?6G@PDfU^FgIMOBakMR`P<2`P<R1@JGeM83/0
  0?l";

Export["~/Desktop/foo.pict", DecodePICT[str], "Binary"]
$\endgroup$
1
  • $\begingroup$ Very cool. Just for reference, what's str a picture of? I'm trying to use imagemagick to convert ~/Desktop/foo.pict to something else, and it's showing up as a 232x75px black box. Is that correct? $\endgroup$
    – Ian Hincks
    Mar 19, 2014 at 22:24
5
$\begingroup$

This is data compressed using Compress. You can uncompress it using Uncompress.

Demonstration:

Rasterize["x", ImageSize -> 25]

Mathematica graphics

Open this cell with Cell>Show Expression (ctrlshift-E):

Cell[BoxData[
 GraphicsBox[RasterBox[CompressedData["
1:eJxTTMoPSmJmYGDQA2IpIAax/4+CUTAKhgbYlsaAHaRtI0MhdU1DVWo1gRT/
YJpDsoFEGEWsgROsiDQKVT02A/FIkWogeUZh1UuJUWgmUG4UioHUMArFNKIj
EQdApBZSUwVOo2AGUGAg9sROdBYgVhOJBhJWTnImJaQQET238crjL7aIU0Vt
00bBKBgFo2DgAQD6B2Cc
   "], {{0, 0}, {7.284046692607004, 12.88715953307393}}, {0, 255},
   ColorFunction->RGBColor],
  ImageSize->25,
  PlotRange->{{0, 7.284046692607004}, {0, 12.88715953307393}}]], "Output",
 CellChangeTimes->{{3.546020312347924*^9, 3.546020338348411*^9}}]

Copy the compressed string and uncompress:

Uncompress["
  1:eJxTTMoPSmJmYGDQA2IpIAax/4+CUTAKhgbYlsaAHaRtI0MhdU1DVWo1gRT/
  YJpDsoFEGEWsgROsiDQKVT02A/FIkWogeUZh1UuJUWgmUG4UioHUMArFNKIj
  EQdApBZSUwVOo2AGUGAg9sROdBYgVhOJBhJWTnImJaQQET238crjL7aIU0Vt
  00bBKBgFo2DgAQD6B2Cc
     "] // Image

Mathematica graphics

$\endgroup$
3
  • $\begingroup$ I tried doing that, and got the error Uncompress::corrupt. Thanks for the advice, though. I wouldn't have thought of trying Uncompress. $\endgroup$ May 14, 2012 at 21:40
  • $\begingroup$ Ah, I see what you mean now. Unfortunately, the head CompressedData doesn't appear in the notebook I'm trying to extract from. Instead, it has the an expression like GraphicsData["PICT", <long string>]. I tried copying that string into Uncompress and didn't get anything useful. $\endgroup$ May 14, 2012 at 21:46
  • $\begingroup$ The Uncompress[...]//Image x is a top-bottom flipped version of Rasterize["x", ImageSize -> 25], as that's a Graphics object. $\endgroup$
    – Karsten 7.
    Nov 28, 2015 at 13:55

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.