source: projects/perl-tools/label-it @ 27

Last change on this file since 27 was 1, checked in by sven, 16 years ago

Erstimport

File size: 4.4 KB
Line 
1#!/usr/bin/perl
2#
3# Gibt alle Parameter als "Schrift" auf Lochstreifen (stdout) aus.
4#
5
6my $debug = 0;
7
8my %letters = (# 12345678
9    'a' => ['********',
10            '   *   *',
11            '   *   *',
12            '********'],
13    'b' => ['********',
14            '*  *   *',
15            '*  *   *',
16            '******* '],
17    'c' => ['********',
18            '*      *',
19            '*      *'],
20    'd' => ['********',
21            '*      *',
22            '*      *',
23            ' ****** '],
24    'e' => ['********',
25            '*   *  *',
26            '*   *  *'],
27    'f' => ['********',
28            '    *  *',
29            '    *  *'],
30    'g' => ['********',
31            '*      *',
32            '*   *  *',
33            '*****  *'],
34    'h' => ['********',
35            '    *   ',
36            '********'],
37    'i' => ['*      *',
38            '********',
39            '*      *'],
40    'j' => ['***    *',
41            '*      *',
42            '********'],
43    'k' => ['********',
44            '   **   ',
45            '***   **'],
46    'l' => ['********',
47            '*       ',
48            '*       '],
49    'm' => ['********',
50            '       *',
51            '     ** ',
52            '       *',
53            '********'],
54    'n' => ['********',
55            '      * ',
56            '  ****  ',
57            ' *      ',
58            '********'],
59    'o' => ['********',
60            '*      *',
61            '********'],
62    'p' => ['********',
63            '   *   *',
64            '   *****'],
65    'q' => ['********',
66            '*      *',
67            '**     *',
68            '********'],
69    'r' => ['********',
70            '   *   *',
71            '*** ****'],
72    's' => ['    ****',
73            '*   *  *',
74            '*****  *'],
75    't' => ['       *',
76            '********',
77            '       *'],
78    'u' => ['********',
79            '*       ',
80            '********'],
81    'v' => ['  ******',
82            '*       ',
83            '  ******'],
84    'w' => ['  ******',
85            '*       ',
86            ' *      ',
87            '*       ',
88            '  ******'],
89    'x' => ['***   **',
90            '   ***  ',
91            '***   **'],
92    'y' => ['    ****',
93            '*   *   ',
94            ' *******'],
95    'z' => ['**     *',
96            '*  *** *',
97            '*     **'],
98    '1' => ['      * ',
99            '********'],
100    '2' => ['**    * ',
101            '*  **  *',
102            '*    ***'],
103    '3' => ['*  *   *',
104            '*  *   *',
105            '********'],
106    '4' => ['    ****',
107            '    *   ',
108            '********',
109            '    *   '],
110    '5' => ['*  *****',
111            '*  *   *',
112            '*  *   *',
113            '****   *'],
114    '6' => ['  ****  ',
115            '***   * ',
116            '*  *   *',
117            '****  * '],
118    '7' => ['       *',
119            '   *   *',
120            '********'],
121    '8' => ['********',
122            '*  *   *',
123            '********'],
124    '9' => ['   *****',
125            '   *   *',
126            '********'],
127    '0' => ['*********',
128            '*       *',
129            '*  ***  *',
130            '*       *',
131            '*********']
132);
133
134$x = 0; # ARGV-Counter
135foreach (@ARGV) {
136    # vor wort ein Leerzeichen lassen wenns nicht das erste ist
137    print pack("C", 0) x 2 unless($x++ == 0);
138
139    #print STDERR "Parameter $_:\n" if $debug;
140    foreach(my $cpos=0; $cpos < length; $cpos++) {
141        my $char = lc substr $_, $cpos, 1;
142        print STDERR "Zeichen $char:\n" if $debug;
143        unless(exists $letters{$char}) {
144            print STDERR "Buchstabe $char kann nicht gedruckt werden\n";
145            next;
146        }
147
148        # anonymes Array einlesen und jeweils string zu octett formen
149        foreach (@{$letters{$char}}) {
150            my $byte = 0;
151            $byte +=   1 if(isPunched($_, 0));
152            $byte +=   2 if(isPunched($_, 1));
153            $byte +=   4 if(isPunched($_, 2));
154            $byte +=   8 if(isPunched($_, 3));
155            $byte +=  16 if(isPunched($_, 4));
156            $byte +=  32 if(isPunched($_, 5));
157            $byte +=  64 if(isPunched($_, 6));
158            $byte += 128 if(isPunched($_, 7));
159            my $pack = pack("C", $byte);
160            printf STDERR "$_: Zahl = $byte = $pack = %d\n", $pack if $debug;
161            print $pack;
162        } # foreach zeichenreihe
163        # Nach Zeichen eine Reihe Platz lassen:
164        print pack("C", 0);
165    } # foreach zeichen
166} # foreach parameter
167
168sub isPunched { return substr($_[0], $_[1], 1) eq '*'; }
169
Note: See TracBrowser for help on using the repository browser.
© 2008 - 2013 technikum29 • Sven Köppel • Some rights reserved
Powered by Trac
Expect where otherwise noted, content on this site is licensed under a Creative Commons 3.0 License