Since we're in the 'festive' season I thought it might be fun to teach Perl to weave! Or at least simulate weaving, in this case convert a .wif file to a .png file (adding a .html file for quick display along the way). For those who are curious a .wif file is a variant on a INI file---same format, but allows for greater than 64k file sizes. At any rate, all of the various pieces of information needed for the simulation, number of threads, color of threads, number of harnesses/shafts, and similar such are read and the result calculated. Building a kind of 'model' loom along the way. There is a significant chance that this code will be pretty much meaningless to anyone but a weaver (very small sigma short of unity) but what the heck, it's hard to do serious coding during Xmas week... Press on for the code

#!/perl/bin/perl
#
# wif2png.pl -- script to convert from a .wif file to a .png for viewi
+ng...
use strict;
use warnings;
use diagnostics;
use IniFile;
use File::Basename;
use GD;

my $ini = new IniFile($ARGV[0]);
my %contents = getSectionHash($ini,'CONTENTS');
my %wif = getSectionHash($ini,'WIF');
my %tieup = getSectionHash($ini,'TIEUP');
my @threading = getSectionArray($ini,'THREADING');
my @treadling = getSectionArray($ini,'TREADLING');
my %weaving = getSectionHash($ini,'WEAVING');
my %color_table = getSectionHash($ini,'COLOR TABLE');
my %warp = getSectionHash($ini,'WARP');
my $warpcolor = $warp{'Color'};
my %weft = getSectionHash($ini,'WEFT');
my $weftcolor = $weft{'Color'};
my %color_palette = getSectionHash($ini,'COLOR PALETTE');
my @color_range = split(',',$color_palette{'Range'});
my @shafts;
my @compositshafts;
my @empty = split(/,/,'0,' x scalar(@threading));
my $im = new GD::Image(scalar(@threading),scalar(@treadling)) or die "
+couldn't create new GD image.\n";
my $WeftColor = gdRGB($im,$color_table{$weftcolor},@color_range);
my @color_table;
my %warp_colors = getSectionHash($ini,'WARP COLORS');
my ($name,$path,$suffix) = fileparse($ARGV[0],'\..*');
my $n;

foreach (keys %color_table) {
    $color_table[$_ - 1] = gdRGB($im,$color_table{$_},@color_range);
}
foreach (1..$weaving{'Shafts'}) {
    push(@shafts,[@empty]);
    push(@compositshafts,[@empty]);
}
foreach (0..@threading - 1) {
    $shafts[$threading[$_] - 1][$_] = ($warp_colors{$_} or $warpcolor)
+;
}
$n = 0;
foreach (keys %tieup) {
    foreach (split(',',$tieup{$_})) {
        foreach ($shafts[$_ - 1]) {
            $compositshafts[$n] = [union($compositshafts[$n],$_)];
        }
    }
    $n++;
}
foreach my $row (0 .. @treadling - 1) {
    foreach my $col (0 .. @threading - 1) {
        if ($compositshafts[$row % 8][$col]) {
            $im->setPixel($col,$row,$color_table[$compositshafts[$row 
+% 8][$col] - 1]);
        }
        else {
            $im->setPixel($col,$row,$WeftColor);
        }
    }
}
open(IMAGE,">$path$name.png") or die "Couldn't open $path$name.png:$!\
+n";
binmode IMAGE;
print IMAGE $im->png();
close IMAGE;
open(HTML,">$path$name.html") or die "Couldn't open $path$name.html:$!
+\n";
print HTML qq(<!doctype html public \"-//W3C//DTD HTML 4.0 Transitiona
+l//EN\">\n);
print HTML qq(<html>\n);
print HTML qq(<head>\n);
print HTML qq(<title>Image</title>\n);
print HTML qq(</head>\n);
print HTML qq(<body>\n);
print HTML qq(<img src=\"$path$name.png\"></body>\n);
print HTML qq(</html>\n);
close HTML;

sub gdRGB {
    my $im = shift;
    my ($rgb,$lowerlimit,$upperlimit) = @_;
    my ($red,$green,$blue) = split(/,/,$rgb);

    unless ($lowerlimit) {
        return $im->colorAllocate(
            int(($red / $upperlimit) * 255),
            int(($green / $upperlimit) * 255),
            int(($blue / $upperlimit) * 255));
    }
    else {
        return undef;
    }
}


sub union {
    my $s1 = shift;
    my $s2 = shift;
    my @union;

    foreach (0..@$s1 - 1) {
        push(@union,@$s1[$_] | @$s2[$_]);
    }
    return @union;
}
    
sub getSectionHash {
    my $ini = shift;
    my $ref = $ini->get([shift]);
    my %hash;

    foreach (keys %$ref) {
        $hash{$_} = $$ref{$_}[0];
    }
    return %hash;
}

sub getSectionArray {
    my $ini = shift;
    my $ref = $ini->get([shift]);
    my @array;

    foreach (keys %$ref) {
        push(@array,$$ref{$_}[0]);
    }
    return @array;
}
__END__

[download]

NOTE---I've not finished testing this code against a wide range of .wif files, so there are still some problems to be worked out/caught etc.

Here is a sample .wif file (for more try a google search of "+.wif +WEAVING"):

[WIF]
Version=1.1
Date=April 20, 1997
Developers=wif@mhsoft.com
Source Program=SwiftWeave
Source Version=5.14
;Created on Wednesday, July 23, 1997

[NOTES]
1=Comment:


[CONTENTS]
NOTES=Yes
WEAVING=Yes
COLOR PALETTE=Yes
COLOR TABLE=Yes
WARP=Yes
THREADING=Yes
WARP THICKNESS=Yes
WARP SPACING=Yes
WARP COLORS=Yes
WEFT=Yes
TREADLING=Yes
LIFTPLAN=No
WEFT THICKNESS=Yes
WEFT SPACING=Yes
TIEUP=Yes

[WEAVING]
Shafts=8
Treadles=8
Rising Shed=Yes

[WEFT]
Color=1
Units=Inches
Symbol=X
Threads=80
Thickness=0.125
Spacing=0.25

[WARP]
Color=3
Units=Inches
Symbol=X
Threads=157
Thickness=0.5
Spacing=0.625

[COLOR PALETTE]
Entries=41
Range=0,65535

[COLOR TABLE]
1=0,0,0
2=1,65535,19252
3=1,65535,21178
4=1,65535,21178
5=1,65535,23104
6=1,65535,25030
7=1,65535,26956
8=1,65535,26956
9=1,65535,28882
10=1,65535,30808
11=1,65535,32734
12=1,65535,32734
13=1,65535,34660
14=1,65535,36586
15=1,65535,38512
16=1,65535,38512
17=1,65535,40438
18=1,65535,42364
19=1,65535,44290
20=1,65535,44290
21=1,65535,46216
22=1,65535,48142
23=1,65535,50067
24=1,65535,50067
25=1,65535,51993
26=1,65535,53919
27=1,65535,55845
28=1,65535,55845
29=1,65535,57771
30=1,65535,59697
31=1,65535,65523
32=1,63621,65535
33=1,61695,65535
34=1,61695,65535
35=1,59769,65535
36=1,57843,65535
37=1,55917,65535
38=1,55917,65535
39=1,53991,65535
40=1,52065,65535
41=1,50139,65535

[THREADING]
1=1
2=2
3=3
4=4
5=5
6=6
7=7
8=8
9=1
10=2
11=3
12=4
13=5
14=6
15=7
16=8
17=1
18=2
19=3
20=4
21=5
22=6
23=7
24=8
25=1
26=2
27=3
28=4
29=5
30=6
31=7
32=8
33=1
34=2
35=3
36=4
37=5
38=6
39=7
40=8
41=7
42=6
43=5
44=4
45=3
46=2
47=1
48=8
49=7
50=6
51=5
52=4
53=3
54=2
55=1
56=8
57=7
58=6
59=5
60=4
61=3
62=2
63=1
64=8
65=7
66=6
67=5
68=4
69=3
70=2
71=1
72=8
73=7
74=6
75=5
76=4
77=3
78=2
79=1
80=2
81=3
82=4
83=5
84=6
85=7
86=8
87=1
88=2
89=3
90=4
91=5
92=6
93=7
94=8
95=1
96=2
97=3
98=4
99=5
100=6
101=7
102=8
103=1
104=2
105=3
106=4
107=5
108=6
109=7
110=8
111=1
112=2
113=3
114=4
115=5
116=6
117=7
118=8
119=7
120=6
121=5
122=4
123=3
124=2
125=1
126=8
127=7
128=6
129=5
130=4
131=3
132=2
133=1
134=8
135=7
136=6
137=5
138=4
139=3
140=2
141=1
142=8
143=7
144=6
145=5
146=4
147=3
148=2
149=1
150=8
151=7
152=6
153=5
154=4
155=3
156=2
157=1

[WARP COLORS]
1=2
3=4
4=5
5=6
6=7
7=8
8=9
9=10
10=11
11=12
12=13
13=14
14=15
15=16
16=17
17=18
18=19
19=20
20=21
21=22
22=23
23=24
24=25
25=26
26=27
27=28
28=29
29=30
30=31
31=32
32=33
33=34
34=35
35=36
36=37
37=38
38=39
39=40
40=41
41=40
42=39
43=38
44=37
45=36
46=35
47=34
48=33
49=32
50=31
51=30
52=29
53=28
54=27
55=26
56=25
57=24
58=23
59=22
60=21
61=20
62=19
63=18
64=17
65=16
66=15
67=14
68=13
69=12
70=11
71=10
72=9
73=8
74=7
75=6
76=5
77=4
79=2
81=4
82=5
83=6
84=7
85=8
86=9
87=10
88=11
89=12
90=13
91=14
92=15
93=16
94=17
95=18
96=19
97=20
98=21
99=22
100=23
101=24
102=25
103=26
104=27
105=28
106=29
107=30
108=31
109=32
110=33
111=34
112=35
113=36
114=37
115=38
116=39
117=40
118=41
119=40
120=39
121=38
122=37
123=36
124=35
125=34
126=33
127=32
128=31
129=30
130=29
131=28
132=27
133=26
134=25
135=24
136=23
137=22
138=21
139=20
140=19
141=18
142=17
143=16
144=15
145=14
146=13
147=12
148=11
149=10
150=9
151=8
152=7
153=6
154=5
155=4
157=2

[TREADLING]
1=1
2=2
3=3
4=4
5=5
6=6
7=7
8=8
9=1
10=2
11=3
12=4
13=5
14=6
15=7
16=8
17=1
18=2
19=3
20=4
21=5
22=6
23=7
24=8
25=1
26=2
27=3
28=4
29=5
30=6
31=7
32=8
33=1
34=2
35=3
36=4
37=5
38=6
39=7
40=8
41=1
42=2
43=3
44=4
45=5
46=6
47=7
48=8
49=1
50=2
51=3
52=4
53=5
54=6
55=7
56=8
57=1
58=2
59=3
60=4
61=5
62=6
63=7
64=8
65=1
66=2
67=3
68=4
69=5
70=6
71=7
72=8
73=1
74=2
75=3
76=4
77=5
78=6
79=7
80=8

[TIEUP]
1=1,4,7,8
2=1,2,8
3=1,2,3
4=2,3,4
5=3,4,5,8
6=1,4,6
7=2,5,7
8=3,6,8

[download]

--hsm

"Never try to teach a pig to sing...it wastes your time and it annoys the pig."

In reply to Weaving with Perl by hsmyers

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.