~ubuntu-branches/ubuntu/trusty/clc-intercal/trusty-proposed

« back to all changes in this revision

Viewing changes to INTERCAL/Charset/Hollerith.pm

  • Committer: Bazaar Package Importer
  • Author(s): Mark Brown
  • Date: 2006-10-08 13:30:54 UTC
  • mfrom: (1.1.1 upstream) (3.1.1 dapper)
  • Revision ID: james.westby@ubuntu.com-20061008133054-fto70u71yoyltr3m
Tags: 1:1.0~2pre1.-94.-4.1-1
* New upstream release.
* Change to dh_installman.

Show diffs side-by-side

added added

removed removed

Lines of Context:
 
1
package Language::INTERCAL::Charset::Hollerith;
 
2
 
 
3
# Convert between Hollerith and ASCII
 
4
 
 
5
# This file is part of CLC-INTERCAL.
 
6
 
 
7
# Copyright (C) 2000, 2002, 2006 Claudio Calvelli, all rights reserved
 
8
 
 
9
# CLC-INTERCAL is copyrighted software. However, permission to use, modify,
 
10
# and distribute it is granted provided that the conditions set out in the
 
11
# licence agreement are met. See files README and COPYING in the distribution.
 
12
 
 
13
use vars qw($PERVERSION);
 
14
$PERVERSION = "CLC-INTERCAL INTERCAL/Charset/Hollerith.pm 1.-94.-6";
 
15
 
 
16
use Carp;
 
17
use strict;
 
18
 
 
19
use Language::INTERCAL::Exporter '1.-94.-4';
 
20
use vars qw(@EXPORT @EXPORT_OK);
 
21
@EXPORT = ();
 
22
@EXPORT_OK = qw(ascii2hollerith hollerith2ascii);
 
23
 
 
24
use Language::INTERCAL::Splats '1.-94.-4', qw(:SP);
 
25
 
 
26
my @bitmask = ("\001\000", "\000\001", "\002\000", "\000\002",
 
27
               "\004\000", "\000\004", "\010\000", "\000\010",
 
28
               "\020\000", "\000\020", '', "\040\000", "\000\040");
 
29
 
 
30
sub mk_hollerith {
 
31
    my ($ascii, @punch) = @_;
 
32
    my $hollerith = "\000\000";
 
33
    while (@punch) {
 
34
        my $punch = shift @punch;
 
35
        die "Internal error (punch=$punch)"
 
36
            if $punch >= @bitmask || $bitmask[$punch] eq '';
 
37
        $hollerith |= $bitmask[$punch];
 
38
    }
 
39
    $hollerith |= "\100\000" if "\000\000" eq ($hollerith & "\040\000");
 
40
    $hollerith |= "\000\100" if "\000\000" eq ($hollerith & "\000\040");
 
41
    ($ascii, $hollerith);
 
42
}
 
43
 
 
44
my %ascii2hollerith = map { mk_hollerith(@$_) } (
 
45
    ["'", 8, 2],
 
46
    [' '],
 
47
    ['!', 0, 9, 7],
 
48
    ['"', 12, 8, 2],
 
49
    ['#', 8, 3],
 
50
    ['$', 11, 8, 3],
 
51
    ['%', 0, 8, 2],
 
52
    ['&', 12, 8, 5],
 
53
    ['(', 0, 8, 4],
 
54
    [')', 12, 8, 4],
 
55
    ['*', 11, 8, 4],
 
56
    ['+', 12],
 
57
    [',', 0, 8, 3],
 
58
    ['-', 11],
 
59
    ['.', 12, 8, 3],
 
60
    ['/', 0, 1],
 
61
    [':', 0, 8, 5],
 
62
    [';', 0, 8, 6],
 
63
    ['<', 11, 0, 8, 4],
 
64
    ['=', 8, 5],
 
65
    ['>', 11, 12, 8, 4],
 
66
    ['?', 11, 8, 2],
 
67
    ['@', 8, 4],
 
68
    ['[', 0, 7, 4],
 
69
    ['\\', 8, 7],
 
70
    [']', 12, 7, 4],
 
71
    ['^', 11, 8, 6],
 
72
    ['_', 12, 11],
 
73
    ['`', 8, 6],
 
74
    ['{', 0, 6, 4],
 
75
    ['|', 11, 8, 5],
 
76
    ['}', 12, 6, 4],
 
77
    ['~', 11, 9, 7],
 
78
    ['�', 12, 0, 1, 3],
 
79
    ['�', 11, 0, 5],
 
80
    ['[]', 12, 0, 7, 4],
 
81
    ["\"\b.", 12, 8, 3, 2],
 
82
    ['0', 0],
 
83
    ['1', 1],
 
84
    ['2', 2],
 
85
    ['3', 3],
 
86
    ['4', 4],
 
87
    ['5', 5],
 
88
    ['6', 6],
 
89
    ['7', 7],
 
90
    ['8', 8],
 
91
    ['9', 9],
 
92
    ['A', 12, 1],
 
93
    ['B', 12, 2],
 
94
    ['C', 12, 3],
 
95
    ['D', 12, 4],
 
96
    ['E', 12, 5],
 
97
    ['F', 12, 6],
 
98
    ['G', 12, 7],
 
99
    ['H', 12, 8],
 
100
    ['I', 12, 9],
 
101
    ['J', 11, 1],
 
102
    ['K', 11, 2],
 
103
    ['L', 11, 3],
 
104
    ['M', 11, 4],
 
105
    ['N', 11, 5],
 
106
    ['O', 11, 6],
 
107
    ['P', 11, 7],
 
108
    ['Q', 11, 8],
 
109
    ['R', 11, 9],
 
110
    ['S', 2, 0],
 
111
    ['T', 3, 0],
 
112
    ['U', 4, 0],
 
113
    ['V', 5, 0],
 
114
    ['W', 6, 0],
 
115
    ['X', 7, 0],
 
116
    ['Y', 8, 0],
 
117
    ['Z', 9, 0],
 
118
    # Punched cards do not have lowercase - we use uppercase with overpunch
 
119
    ['a', 12, 1, 0],
 
120
    ['b', 12, 2, 1],
 
121
    ['c', 12, 3, 2],
 
122
    ['d', 12, 4, 3],
 
123
    ['e', 12, 5, 4],
 
124
    ['f', 12, 6, 5],
 
125
    ['g', 12, 7, 6],
 
126
    ['h', 12, 8, 7],
 
127
    ['i', 12, 9, 8],
 
128
    ['j', 11, 1, 0],
 
129
    ['k', 11, 2, 1],
 
130
    ['l', 11, 3, 2],
 
131
    ['m', 11, 4, 3],
 
132
    ['n', 11, 5, 4],
 
133
    ['o', 11, 6, 5],
 
134
    ['p', 11, 7, 6],
 
135
    ['q', 11, 8, 7],
 
136
    ['r', 11, 9, 8],
 
137
    ['s', 2, 1, 0],
 
138
    ['t', 3, 2, 0],
 
139
    ['u', 4, 3, 0],
 
140
    ['v', 5, 4, 0],
 
141
    ['w', 6, 5, 0],
 
142
    ['x', 7, 6, 0],
 
143
    ['y', 8, 7, 0],
 
144
    ['z', 9, 8, 0],
 
145
    # overline (tall worm?) is 11, 0
 
146
    # the following codes do not exist in Hollerith - we use "Christmas lights"
 
147
    ["\n", 12, 9, 8, 7, 6, 5, 4, 3, 2, 1],
 
148
    ["\r", 11, 9, 8, 7, 6, 5, 4, 3, 2, 1],
 
149
    ["\t", 0, 9, 8, 7, 6, 5, 4, 3, 2, 1],
 
150
);
 
151
 
 
152
my %asciimultiple = map { (substr($_, 0, length($_) - 1) => 1) }
 
153
                        grep { length($_) > 1 }
 
154
                             keys %ascii2hollerith;
 
155
 
 
156
my %hollerith2ascii = reverse %ascii2hollerith;
 
157
 
 
158
#print join(' ', sort values %ascii2hollerith), "\n";
 
159
#print join(' ', sort keys %hollerith2ascii), "\n";
 
160
die "Internal error" if keys %ascii2hollerith != keys %hollerith2ascii;
 
161
 
 
162
sub hollerith2ascii {
 
163
    @_ == 1 or croak "Usage: hollerith2ascii(STRING)";
 
164
    my $string = shift;
 
165
    my $result = '';
 
166
    while ($string ne '') {
 
167
        my $char = substr($string, 0, 2);
 
168
        $string = substr($string, 2);
 
169
        $char .= "\000" if length($char) == 1;
 
170
        $char &= "\077\077";
 
171
        $char |= "\100\000" if "\000\000" eq ($char & "\040\000");
 
172
        $char |= "\000\100" if "\000\000" eq ($char & "\000\040");
 
173
        if (! exists $hollerith2ascii{$char}) {
 
174
            my @punch = ();
 
175
            for (my $punch = 0; $punch < @bitmask; $punch++) {
 
176
                push @punch, $punch if $bitmask[$punch] ne '' &&
 
177
                                       ($char & $bitmask[$punch]) ne "\000\000";
 
178
            }
 
179
            push @punch, '(empty' unless @punch;
 
180
            my $punch = join('-', sort { $b <=> $a } @punch);
 
181
            faint(SP_NOSUCHCHAR, $punch, "Hollerith")
 
182
        }
 
183
        $result .= $hollerith2ascii{$char};
 
184
    }
 
185
    $result;
 
186
}
 
187
 
 
188
sub ascii2hollerith {
 
189
    @_ == 1 or croak "Usage: ascii2hollerith(STRING)";
 
190
    my $string = shift;
 
191
    my $result = '';
 
192
    while ($string ne '') {
 
193
        my $char = substr($string, 0, 1);
 
194
        $string = substr($string, 1);
 
195
        while ($string ne '' && exists $asciimultiple{$char}) {
 
196
            my $next = substr($string, 0, 1);
 
197
            last if ! exists $asciimultiple{$char . $next} &&
 
198
                    ! exists $ascii2hollerith{$char . $next};
 
199
            $char .= $next;
 
200
            $string = substr($string, 1);
 
201
        }
 
202
        $result .= $ascii2hollerith{$char} ||
 
203
            faint(SP_NOSUCHCHAR, $char, "Hollerith")
 
204
    }
 
205
    $result;
 
206
}
 
207
 
 
208
1;
 
209
 
 
210
__END__
 
211
 
 
212
=head1 NAME
 
213
 
 
214
Charset::Hollerith - allows to use Hollerith string constants in ASCII programs (and v.v.)
 
215
 
 
216
=head1 SYNOPSIS
 
217
 
 
218
    use Charset::Hollerith qw(hollerith2ascii);
 
219
 
 
220
    my $a = hollerith2ascii "(Hollerith text)";
 
221
 
 
222
=head1 DESCRIPTION
 
223
 
 
224
I<Charset::Hollerith> defines functions to convert between a subset of ASCII
 
225
and a subset of nonstandard Hollerith (since there isn't such a thing as a
 
226
standard
 
227
Hollerith we defined our own variant which is guaranteed to be incompatible
 
228
with all versions of Hollerith used by IBM hardware - however, for each
 
229
character code we have used the code used by some (but not all) IBM card
 
230
reader, if the code exists in Hollerith at all, or we have made one up
 
231
in some logical way (such as overpunching) if no IBM hardware had that
 
232
particular character.
 
233
 
 
234
The two functions I<hollerith2ascii> and I<ascii2hollerith> are exportable
 
235
but not exported by default. They do the obvious thing to their argument.
 
236
 
 
237
=head1 HOLLERITH CHARACTER TABLE
 
238
 
 
239
A Hollerith string is a sequence of 12-bit characters; they are encoded as
 
240
two ASCII characters, containing 6 bits each: the first character contains
 
241
punches 12, 0, 2, 4, 6, 8 and the second character contains punches 11, 1,
 
242
3, 5, 7, 9; interleaving the two characters gives the original 12 bits.
 
243
To make the characters printable on ASCII terminals, bit 7 is always set to 0,
 
244
and bit 6 is set to the complement of bit 5. These two bits are ignored when
 
245
reading Hollerith cards.
 
246
 
 
247
Some Hollerith characters (produced by overpunching) can be converted
 
248
to sequences of ASCII characters; I<ascii2hollerith> will correctly
 
249
recognise the sequences.
 
250
 
 
251
The following punched cards document the encoding of characters (the last
 
252
three symbols at the end nongraphic symbols in ASCII; the previous two
 
253
symbols correspond to multicharacter sequences):
 
254
 
 
255
        ' !"#$%&()*+,-./:;<=>?@[\]^_`{|}~��0123456789     
 
256
   12      *   * * *  *     *    * *   * *              12
 
257
   11        *    *  *    * **    **  * * *             11
 
258
    0     *   * *   *  ****    *     *   ***             0
 
259
    1                  *                 *  *            1
 
260
    2   *  *  *              *               *           2
 
261
    3       **      * *                  *    *          3
 
262
    4           ***       * * ** *   * *       *         4
 
263
    5          *        *  *          *   *     *        5
 
264
    6                    *        * ** *         *       6
 
265
    7     *                    ***      *         *      7
 
266
    8   *  ******** * * ******* * * * *            *     8
 
267
    9     *                             *           *    9
 
268
 
 
269
        ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs     
 
270
   12   *********                 *********             12
 
271
   11            *********                 *********    11
 
272
    0                     *********        *        *    0
 
273
    1   *        *                **       **       *    1
 
274
    2    *        *       *        **       **      *    2
 
275
    3     *        *       *        **       **          3
 
276
    4      *        *       *        **       **         4
 
277
    5       *        *       *        **       **        5
 
278
    6        *        *       *        **       **       6
 
279
    7         *        *       *        **       **      7
 
280
    8          *        *       *        **       **     8
 
281
    9           *        *       *        *        *     9
 
282
 
 
283
        tuvwxyz []  ".  NL  CR  HT      
 
284
   12            *   *   *            12
 
285
   11                        *        11
 
286
    0   *******  *               *     0
 
287
    1                    *   *   *     1
 
288
    2   *            *   *   *   *     2
 
289
    3   **           *   *   *   *     3
 
290
    4    **      *       *   *   *     4
 
291
    5     **             *   *   *     5
 
292
    6      **            *   *   *     6
 
293
    7       **   *       *   *   *     7
 
294
    8        **      *   *   *   *     8
 
295
    9         *          *   *   *     9
 
296
 
 
297
=head1 COPYRIGHT
 
298
 
 
299
This module is part of CLC-INTERCAL.
 
300
 
 
301
Copyright (C) 2000, 2002, 2006 Claudio Calvelli, all rights reserved.
 
302
 
 
303
See the files README and COPYING in the distribution for information.
 
304
 
 
305
=head1 SEE ALSO
 
306
 
 
307
A qualified psychiatrist.
 
308