DouKaku?beta

Language detail: PostScript

Coverage: 27.41%
number of '+' ratings
 contribution for coverage

Unsolved challenges

show all

codes

Feed

Used modules

next >>

ラングトンのアリの描画 (Nested Flatten)

http://d.hatena.ne.jp/yshl/20090726 から転載です

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
%!PS
gsave
    0 dict begin
        /fieldsize 100 def
        /white [1 1 1] def
        /field [ fieldsize{ [fieldsize{ white }repeat] }repeat ] def
        /check-mark{
            % ant -- bool
            begin
                field position-x get position-y get
                color eq
            end
        }def
        /draw-mark{
            % ant --
            begin
                field position-x get position-y color put
            end
        }def
        /erase-mark{
            % ant --
            begin
                field position-x get position-y white put
            end
        }def

        /generate-ant{
            % init-x init-y direction-x direction-y color -- dict
            5 dict begin
                /color exch def
                /direction-y exch def
                /direction-x exch def
                /position-y exch def
                /position-x exch def
                currentdict
            end
        }def
        /move{
            % ant --
            begin
                /position-x position-x direction-x add def
                /position-y position-y direction-y add def
            end
        }def
        /turn-left{
            % ant --
            begin
               direction-y neg
               direction-x
               /direction-y exch def
               /direction-x exch def
           end
        }def
        /turn-right{
            % ant --
            begin
                direction-y
                direction-x neg
                /direction-y exch def
                /direction-x exch def
            end
        }def
        
        /draw-field{
            2 2 scale
            0 1 fieldsize 1 sub{
                % x
                0 1 fieldsize 1 sub{
                % x y
                    field 2 index get 1 index get
                    aload pop setrgbcolor
                    2 copy 1 1 rectfill
                    pop
                }for
                pop
            }for
            showpage
        }def

        /ant1
            fieldsize 2 idiv dup 0 1 [0 0 0] generate-ant
        def
        0 1 20000{
            ant1
            dup check-mark{
                dup erase-mark
                dup turn-right
                move
            }{
                dup draw-mark
                dup turn-left
                move
            }ifelse
            ant1 begin
                position-x dup 0 lt exch fieldsize ge or
                position-y dup 0 lt exch fieldsize ge or
                or
            end
            {
                exit
            }if
            % 20歩毎に表示
            20 mod 0 eq{
                draw-field
            }if
        }for
    end
grestore
ストレンジアトラクタの描画 (Nested Flatten)

以前書いた PostScript によるローレンツアトラクタです。微分方程式はオイラー法で解いています。

see: 

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
%PS!
gsave

% パラメータ
% dx/dt=-px+py
% dy/dt=-xz+rx-y
% dz/dt=xy-bz
/p 10 def /r 28 def /b 8 3 div def
% 時間ステップ
/dt 0.003 def
% 繰り返し回数と何回毎に描くか
/skip 25 def
/times skip 360 mul def
% 初期位置
/initx 10 def /inity 0 def /initz 40 def
% 射影の方向
/theta 60 def /phi 30 def
% 一回描く毎の射影方向の回転角
/dphi 1 def
% 図の位置と倍率
/ctm 70 8 translate 2 2 scale 6 array currentmatrix def
/lwidth 0.5 def

/fx{
    % x y z -> (y-x)*p
    pop exch sub p mul
}bind def
/fy{
    % x y z -> x*(r-z)-y
    r exch sub 3 2 roll mul exch sub
}bind def
/fz{
    % x y z -> x*y-b*z
    b mul 3 1 roll mul exch sub
}bind def
/step{
    % x y z -> x+dx y+dy z+dz
    3 dict begin
        /z exch def /y exch def /x exch def
        x x y z fx dt mul add
        y x y z fy dt mul add
        z x y z fz dt mul add
    end
}bind def
/addstep{
    % arr -> newarr
    dup length 1 add array dup dup 4 2 roll copy length
    [ 3 copy pop 1 sub get aload pop step ] put
}bind def
/addstep1{
    % 別バージョン
    [
        exch aload pop
        dup [ exch aload pop step ]
    ]
}bind def
/projection{
    % x y z -> Px Py
    3 dict begin
        /z exch def /y exch def /x exch def
%        y phi cos mul x theta sin mul z theta cos mul add phi sin mul sub
%        z theta sin mul x theta cos mul sub
        y phi cos mul x phi sin mul sub
        z theta sin mul x phi cos mul y phi sin mul add theta cos mul sub
    end
}bind def

[[initx inity initz]]
0 1 times{
    dup skip mod 0 eq{
        times div 1.0 0.75 sethsbcolor
        ctm setmatrix
        lwidth setlinewidth

        initx inity initz projection moveto
        dup{
            aload pop projection
            lineto
        }forall
        stroke

        dup dup length 1 sub get aload pop projection
        0 0 0 setrgbcolor
        lwidth 2 mul 0 360 arc fill

        showpage
        /phi phi dphi add def
    }{
        pop
    }ifelse
    addstep
}bind for

grestore
エレベータの制御(基本編) (Nested Flatten)

とりあえず、サンプル通りのやつと、自分なりに最適化したのを1本づつ。 方針としては、トータルの待ち時間の最小化です。 各人が1階まで降りる時間*人数の合計が最小になるように、という方針です。

実際のところは、下の階層から優先的に運び出してしまって、上の階層は後回し、ということです。定員まで余裕があれば、更に上の階層へ寄り道、という手順になります。

サンプルプログラム(FindNext2)の手順だと、 Score =3464 Time =209 Run =52 ですが、この手順(FindNext1)ですと、 Score =2931 Time =222 Run =56 となり、若干エレベータの移動量(Run)及び所要時間(Time)が増えるものの、大幅に合計待ち時間(Score)が短縮されます。

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
%!PS

% [[待ち人] 現在位置 乗員 定員 時刻 評価]   Check1  [...]
/Check1 {
    dup 0 get true exch { 0 eq and } forall % 待ち無し
    1 index 1 get 0 eq and                  % 地上階    
} bind def

% [[待ち人] 現在位置....] FindNext1 num
/FindNext1 {
    0 2 getinterval aload
    0 get length 1 sub 1 exch {
        2 copy get 0 gt {
            exch pop true exit
        } if
        pop
    } for
    true ne {
        0
    } if
} bind def

/FindNext2 {
    (==) = ppstack (==)=
    0 get
    dup length 1 sub -1 1
    {
        2 copy get 0 gt {
            exch pop true exit
        } if
        pop
    } for
    true ne {
        0
    } if
} bind def

/AddVal { % [] pos tt  AddVal  []
    2 index 2 index get add 2 index 3 1 roll put
} bind def

% [[待ち人] 現在位置 乗員 定員 時刻 評価]  /Next  Move1  [...]
/Move1 {
    exch
    (Move: ) print dup 1 get 1 add 3 string cvs print ( ==> ) print

    (==) = ppstack
    dup 2 2 getinterval aload pop lt {
        dup 3 -1 roll cvx exec
        1 index 1 get
        2 index 2 index 1 exch put
        sub abs
        2 copy 6 exch AddVal pop
        MoveTime mul 4 exch AddVal
    } {
        exch pop
        dup 1 get
        2 copy 6 exch AddVal pop
        MoveTime mul 4 exch AddVal
        dup 1 0 put
    } ifelse
    dup 1 get 1 add 3 string cvs =
    dup ===
} bind def
/RideOn {
    % [[] ... ] n RideOn [[] ...]
    1 index 0 get 2 index 1 get 2 index neg
    AddVal pop
    2 exch AddVal
} bind def
/IO1 {
    dup 1 get 0 eq {
        (Floor 1 =[Out]= ) print dup 2 get =
        dup 2 get 0 gt {
            4 IOTime AddVal
            dup 2 get exch dup 4 get 3 -1 roll mul
            5 exch AddVal
            dup 2 0 put
        }if
        dup ===
    } {
        (Floor ) print dup 1 get 1 add 3 string cvs print ( =[In]= ) print
        dup 1 get exch dup 0 get 3 -1 roll get
        exch dup 2 get exch dup 3 get 3 -1 roll sub
        3 copy 3 -1 roll lt {
            pop 3 -1 roll pop
        } {
            pop pop exch
        } ifelse
        dup 0 gt {
            dup =
            RideOn
            4 IOTime AddVal
        } {
            (noop) =
        } ifelse
    } ifelse
} bind def


/Run {
    exch
    {
        Check1 { exit } if
        1 index Move1
    IO1
    } loop
    (Score =) print dup 5 get =
    (Time  =) print dup 4 get =
    (Run   =) print dup 6 get =
    pop pop
} bind def

% ===== Test Code =====
/MoveTime 2 def
/IOTime 5 def
[[0 7 3 11 7] 0 0 3 0 0 0] /FindNext2 Run
[[0 7 3 11 7] 0 0 3 0 0 0] /FindNext1 Run
原稿用紙 (Nested Flatten)

ちょっと難しいけど、日本語を勉強します。

書き漢字の練習のためにＰｏｓｔＳｃｒｉｐｔで原稿用紙ジェネレーターを作った。

Program (free software, GPL):

http://www.metamorpher.de/files/genkouyoushi.ps

Example output:

http://www.metamorpher.de/files/genkouyoushi_20x20.pdf

http://www.metamorpher.de/files/genkouyoushi_10x10.pdf

http://www.metamorpher.de/files/genkouyoushi_kana.pdf

http://www.metamorpher.de/files/genkouyoushi_jouyou.pdf

道順を数える (Nested Flatten)

PostScript で2通り。 CountPath1 は (1) タイプ専用で、サイズ((1) では 3 4 )を受けとって解を出力します。

CountPath は 接続図の配列を受けて解を出力します。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
!PS

% Ans 1   サイズのみから (1)のみ計算
/fact { dup 1 gt { dup 1 sub fact mul } if } def
/CountPath1 { 2 copy add fact exch fact idiv exch fact idiv } def

% Ans 2   (2) 
/CountPath {
    [ 1 index 1 get length {1} repeat ] exch
    {
        dup length 0 1 3 -1 roll 1 sub {
            2 copy get
            dup 2 and 0 eq { 0 } { 3 index 2 index get } ifelse
            exch 1 and 0 ne { 3 index 2 index 1 sub get add } if
            3 index 3 1 roll put
        } for
        pop
    } forall
    dup length 1 sub get
} def

% === Test ===
% 1:左に繋がる 2:上に繋がる 3:両方に繋がる
/Map1 [
    [ 2 1 1 1 ]
    [ 2 3 3 3 ]
    [ 2 3 3 3 ]
    [ 2 3 3 3 ]
    [ 2 3 3 3 ]
] def

/Map2 [
    [ 2 1 1 1 ]
    [ 2 3 3 3 ]
    [ 2 1 3 2 ]
    [ 2 3 2 3 ]
    [ 2 3 3 3 ]
] def

3 4 CountPath1 =
Map1 CountPath =
Map2 CountPath =
LL Golf Hole 8 - 横向きのピラミッドを作る (Nested Flatten)

PostScript のカバレッジ稼ぎ... 工夫すればするほど長くなっていく困った状況です。 紙出力版とターミナル出力版、それぞれ何通りか放りこんであります。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
%!PS

% 紙出力-黒ベタ
/r{rlineto}def/P1{2{dup{1 0 r 0 1 r}repeat -1 1 scale 1 sub}repeat -1 0 r closepath fill pop}def
% 紙出力-黒ベタ2
/L{{neg dup rotate 0 1 rlineto}repeat}def/P2{2 mul dup 90 exch L neg exch 1 sub L closepath fill}def
% 紙出力-文字
/d{def}def/p{pop}d/s{show}d/m{0 0 moveto}d/t{repeat 0 h translate}d/i{index}d/P3{1 i true charpath pathbbox/h exch d p p p 1 1 2 i{m{1 i s}t}for 1 sub -1 1{m{dup s}t}for p p}d

%ターミナル出力
/R{repeat}def/D{dup{(*)print}R()= 1}def/P4{1 exch{D add}R 2 sub dup{D sub}R pop}def
% ========= Test Code ========
gsave
% 座標と大きさの設定
100 200 translate 0 0 moveto 20 20 scale
4 P1
grestore
%------------------------
gsave
% 座標と大きさの設定
400 400 translate 0 0 moveto 20 20 scale
4 P2
grestore
%------------------------
gsave
% 座標とフォントの設定
100 400 translate 0 0 moveto
/Times-Roman findfont 32 scalefont setfont
(*) 4 P3
grestore
%------------------------
showpage
%------------------------
4 P4
漢数字で九九の表 (Nested Flatten)

PostScript で。

なでしこ に憧れつつ書いてみました。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
%!PS
% 文字コードt : euc-jp

% マクロ定義
/漢数字 [(０) (一) (二) (三) (四) (五) (六) (七) (八) (九)] def
/空命令 {{}} bind def
/定義する {def} bind def
/として 空命令 定義する
/は 空命令 として 定義する
/の は 空命令 として 定義する
/に は 空命令 として 定義する
/を は 空命令 として 定義する
/と は 空命令 として 定義する
/て は 空命令 として 定義する
/で は 空命令 として 定義する
/長さ は {length} として 定義する
/コピーし は {dup} として 定義する
/入れ替え は {exch} として 定義する
/足し は {add} として 定義する
/掛け は {mul} として 定義する
/引き は {sub} として 定義する
/引い は {sub} として 定義する
/で割った余り は {mod} として 定義する
/割り は {idiv} として 定義する
/捨てる は {pop} として 定義する
/指定回数繰り返す は {for} として 定義する
/一 は [()] の 長さ として 定義する
/番目をコピー は {一 を 引い て index} として 定義する

/たもの は 空命令 として 定義する
/から は 空命令 として 定義する
/まで は 空命令 として 定義する
/する は 空命令 として 定義する
/づつ は 空命令 として 定義する
/もし は 空命令 として 定義する
/して は 空命令 として 定義する
/であったら は 空命令 として 定義する
/を実行する は {if} として 定義する
/を実行し、さもなくば は 空命令 として 定義する
/をかわりに実行する は {ifelse} として 定義する
/以上 は {ge} として 定義する
/番目を取り出す {get} として 定義する


% ここからメイン
/二 は 一 を コピーし 足し たもの として 定義する
/三 は 一 と 二 を 足し たもの として 定義する
/四 は 二 と 二 を 足し たもの として 定義する
/九 は 三 を コピーし 掛け たもの として 定義する
/十 は 四 に 二 と 三 を 掛け て 足し たもの として 定義する
/改行する は {() =} として 定義する
/出力する は {print} として 定義する
/漢数字変換 は {
  コピーし て 十 で割った余り を 漢数字 と 入れ替え て 番目を取り出す
  入れ替え て
  もし コピーし て 十 以上 であったら
  {
      十 で 割り 漢数字 と 入れ替え て 番目を取り出す
  } を実行し、さもなくば
  {
      捨てる
      (　) % 全角空白
  } をかわりに実行する
} として 定義する


一 から 一 づつ 九 まで {
    一 から 一 づつ 九 まで {
    二 番目をコピー して 掛け
        漢数字変換 して 出力する 出力する ( ) を 出力する
    } を 指定回数繰り返す
    捨てる
    改行する
} を 指定回数繰り返す
文字列型日時ののN秒後時間取得 (Nested Flatten) 
PostScript で。
すっかり泥沼化してしまったので、まだバグがあるかもしれません。
対応は日本時間のみで、1970-2050年に対応。
ただし、2009年7月1日以降、1/1, 7/1 の午前9時を含む計算で各1秒のずれが
生じる可能性があります(仕様)。

(20080927000010) -40 DateEx ==> (20080926235930)
(20080101085900) 60 DateEx  ==> (20080101090000)
(20080101085900) 120 DateEx ==> (20080101090100)
(20090101085900) 60 DateEx  ==> (20090101085960) (うるう秒)
(20090101085900) 120 DateEx ==> (20090101090059) (うるう秒)

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
%!PS

/JST 9 60 60 mul mul def
/LDAY 24 60 60 mul mul def
/MOFF [
    0 31 dup 28 add dup 31 add dup 30 add dup 31 add dup 30 add dup 31 add
    dup 31 add dup 30 add dup 31 add dup 30 add dup 31 add
] def

/StrToUTC0 { % (Date String)  StrToUTC  MJD  UTC_L
    % Get UTC / Ignore TZ & leap secs.
    dup 8 2 getinterval cvi 3600 mul exch
    dup 10 2 getinterval cvi 60 mul exch
    dup 12 2 getinterval cvi exch
    4 1 roll add add
    exch

    dup 0 4 getinterval cvi exch
    dup 4 2 getinterval cvi
    dup 2 le {
        3 -1 roll 1 sub 3 1 roll
    12 add
    } if
    exch
    6 2 getinterval cvi
    exch 2 sub 30.59 mul cvi
    add exch
    dup 365.25 mul cvi exch
    dup 400 div cvi exch
    100 div cvi sub add add
    678912 sub
    exch
} bind def

/LeapSecs0 [
   [  (19720630235960) StrToUTC0 ]
   [  (19721231235960) StrToUTC0 ]
   [  (19731231235960) StrToUTC0 ]
   [  (19741231235960) StrToUTC0 ]
   [  (19751231235960) StrToUTC0 ]
   [  (19761231235960) StrToUTC0 ]
   [  (19771231235960) StrToUTC0 ]
   [  (19781231235960) StrToUTC0 ]
   [  (19791231235960) StrToUTC0 ]
   [  (19810630235960) StrToUTC0 ]
   [  (19820630235960) StrToUTC0 ]
   [  (19830630235960) StrToUTC0 ]
   [  (19850630235960) StrToUTC0 ]
   [  (19871231235960) StrToUTC0 ]
   [  (19891231235960) StrToUTC0 ]
   [  (19901231235960) StrToUTC0 ]
   [  (19920630235960) StrToUTC0 ]
   [  (19930630235960) StrToUTC0 ]
   [  (19940630235960) StrToUTC0 ]
   [  (19951231235960) StrToUTC0 ]
   [  (19970630235960) StrToUTC0 ]
   [  (19981231235960) StrToUTC0 ]
   [  (20051231235960) StrToUTC0 ]
   [  (20081231235960) StrToUTC0 ]
] def

/LeapSecs 30 dict def
LeapSecs0 {
    LeapSecs exch aload pop put
} forall

/IsLeapDay { % MJD  IsLeapDay  bool
    LeapSecs exch known
} bind def

/Normalize { % MJD secs  Normalize   MJD' secs'
    {
        dup 0 lt {
            LDAY add
            exch 1 sub exch
            LeapSecs 2 index known { 1 add } if
        } {
            dup LDAY eq {
                LeapSecs 2 index known { exit } if
            } if
            dup LDAY lt {
                exit
            } if
            LeapSecs 2 index known {
                1 sub
            } if
            LDAY sub
            exch 1 add exch
        } ifelse
    } loop
} bind def

/StrToUTC { % (Date String)  StrToUTC  MJD  secs
    dup
    StrToUTC0
    JST sub
% (Date) MJD secs'

   dup 0 lt {
       exch 1 sub exch LDAY add
   } if

    dup 0 eq {
       1 index 1 sub IsLeapDay
       {
           2 index 8 6 getinterval (085960) eq
           {
               exch 1 sub exch LDAY add
           } if
       } if
   } if
   Normalize
   3 -1 roll pop
} bind def

/cvs2 { % int  cvs2  (dd)
    2 string dup dup 3 index
    % int () () 
    10 idiv 1 string cvs 0 exch putinterval
    3 -1 roll 10 mod 1 string cvs 1 exch putinterval
} bind def


/CompTime {
    % MJD sec () MJD' sec'  CompTime  MJD sec ()   -1/0/1
    % LocalFunction
    3 index sub exch
    4 index sub
    % MJD sec () sec'' MJD''
    dup 0 lt {
        pop pop -1
    } {
        0 gt {
            pop 1
        }{
            dup 0 lt {
                pop -1
            } {
                0 gt {
                    1
                } {
                    0
                } ifelse
            } ifelse
        } ifelse
    } ifelse
} bind def


/UTCToStr { %  MJD secs  UTCToStr  (Date String)
    14 string dup 0 (20080101000000) putinterval
    2050 -1 1970 {
        4 string cvs 1 index 0 3 -1 roll putinterval
        dup StrToUTC CompTime
        0 le { exit } if
    } for
    12 -1 1 {
        cvs2 1 index 4 3 -1 roll putinterval
        dup StrToUTC CompTime
        0 le { exit } if
    } for
    31 -1 1 {
        cvs2 1 index 6 3 -1 roll putinterval
        dup StrToUTC CompTime
        0 le { exit } if
    } for
    23 -1 0 {
    cvs2 1 index 8 3 -1 roll putinterval
    dup StrToUTC CompTime
    0 le { exit } if
    } for
    % MJD secs (Date)
    dup StrToUTC exch pop
    % MJD secs (Date) secs'
    4 2 roll exch pop sub neg
    % (Date) secs
    dup 3600 eq { % leap second
    pop dup 10 (5960) putinterval
    } {
           dup 60 idiv
    % (Date) secs min
    cvs2 2 index 10 3 -1 roll putinterval
    % (Date) secs
    60 mod cvs2 1 index 12 3 -1 roll putinterval
    } ifelse
} bind def

/DateEx { % (Date String)  secs   DateEx   (New Date String)
    exch StrToUTC
    3 -1 roll add
    Normalize
    UTCToStr
} bind def

% =========================================================

% Test Code

(20080927000010) -40 DateEx ==
(20080101085900) 60 DateEx  ==
(20080101085900) 120 DateEx ==
(20090101085900) 60 DateEx  ==
(20090101085900) 120 DateEx ==
LL Golf Hole 2 - 文字列に含まれる単語の最初の文字を大文字にする (Nested Flatten)

PostScript でもう少し真面目に。上のも含めて標準出力に出力します。

1
2
3
4
5
6
7
8
9
[(LL future)(LL day and night)(echo $home)(hello,  i am a cat.)]/l{( )search exch dup(a)ge 1 index({)lt and{0 2 copy get -33 and put[}if pop{pop l}if}def{dup l =}forall
% 出力
LL Future
LL Day And Night
Echo $home
Hello,  I Am A Cat.

% バイナリーエンコードする場合はこちらの方が短い
[(LL future)(LL day and night)(echo $home)(hello,  i am a cat.)]{dup{( )search exch dup(a)ge 1 index({)lt and{0 2 copy get -33 and put[}if pop not{exit}if pop}loop =}forall

PostScript 不真面目版。スペースが2個続くとエラーで止まります。

余談ですが、s/与力/余力/ ですね。

1
2
3
4
5
6
7
[(LL future)(LL day and night)]/l{( )search exch 0 2 copy get -33 and put{pop l}if}def{dup l =}forall
% 出力
LL Future
LL Day And Night

% バイナリーエンコードする場合はこちらをエンコードしたものの方が短い
[(LL future)(LL day and night)]{dup{( )search exch 0 2 copy get -33 and put not{exit}if pop}loop =}forall
環境変数の取得 (Nested Flatten)

親OS上の環境変数の取得ということで、GhostScript 依存の getenv operator を使用しました。 PostScript の本来の環境変数（デバイス解像度等）は普通に currentdict 中に入っているわけで、普通に変数名だけで参照できるわけですが、マクロ等も一緒に入っているのでいわゆる変数一覧、というのは 膨大になると思います。後半のようにうっかり forall を使ってアクセスするとスタックがあふれたりとか....

1
2
3
4
5
6
7
%!PS

(PATH) getenv { = } if

% ========= Cut Here ===========
%!PS
currentdict { === } forall
コード圧縮 (Nested Flatten)

Postscript では、通常、コードは実行可能な圧縮配列の形で current dict に記録されるので、それを書きだす、という方向 でいいのでしょうかね.... あまり潰しが利きませんが...

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
%!PS

% テスト用コード
/TestProc { % Hogehoge Fugafuga
    1 3 roll 10 add % areare
    (abc%Hoge) == == % zzz
} def

% ========  出力
currentdict /TestProc get ==

% ======== 以下出力結果
% {1 3 roll 10 add (abc%Hoge) == ==}
比較しないソートの作成 (Nested Flatten)

PostScriptで、radix sort 基数2 です。 特にかわったことはやっていない筈です。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
%!PS

/AddToVector { % val [Vector]  AddToVector  [NewVector]
    [ 3 1 roll
    {
        1 index add exch
    } forall
    pop
    ]
} bind def

/RadixSortCore { % [Vector]  max  RadixSortCore  [NewVector]
    5 dict begin 
    /Max exch def
    /Vect exch def
    /Radix 1 def
    {
        /Vect
        [
            Vect {
                dup Radix and 0 ne {
                    pop
                } if
            } forall
            Vect {
                dup Radix and 0 eq {
                    pop
                } if
            } forall
        ] def
        Radix Max gt { exit } if
        /Radix Radix dup add def
    } loop
    Vect
    end
} bind def

/RadixSort { % min max [Vector] RadixSort [NewVector]
    2 index neg exch AddToVector exch 2 index sub
    RadixSortCore
    AddToVector
} bind def

% ============ Test Code ==============
-1024 2048 [ -510 10 7 12 45 120 -1024 -511 -512 249 1238 1274 ] RadixSort ==
設定ファイルから値を取得 (Nested Flatten) 
普通 PostScript ではプリンタ依存性が大きくなるので外部ファイルの読み込みをユーザープログラムでやることはないと思います。
ここでは GhostScript で試しています。

ShowPrice.ini
--- Cut Here ---
/ITEM_NAME (リンゴ)
/ITEM_COST 200
--- Cut Here ---

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
%!PS

/ReadPrice { % (filename.ini)  ReadPrice  -dict-
    << exch runlibfile >>
} bind def

% --- Test Code ---

(ShowPrice.ini) ReadPrice

dup (ITEM_NAME) get
(「) print print (」は) print

dup (ITEM_COST) get
1.05 mul 0.5 add cvi 10 string cvs print (円(税込み)) =

pop
コメントの削除 (Nested Flatten)

修正版... 文字列中に%を書けたとは...

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
%!PS

/Decomment { % (filename) Decomment -
    true exch
    0 exch
    (r) file
    {
        % outputflag file
        dup read
        not { exit } if
        dup 40 eq {
            3 -1 roll 1 add 3 1 roll
        } if
        dup 41 eq {
            3 -1 roll 1 sub 3 1 roll
        } if
        dup 37 eq {
            2 index 0 eq {
                4 -1 roll pop false 4 1 roll
            } if
        } if
        dup dup 10 eq exch 13 eq or {
            4 -2 roll pop pop true 0 4 2 roll
        } if
        3 index {
            ( ) dup 0 4 -1 roll put
            print
        } {
            pop
        } ifelse 
    } loop
    pop pop pop
} bind def

%---- Test Code ----
(====%===) pop % ==
(decomment.ps) Decomment
n人中m人が当選するくじ (Nested Flatten)

n 人中1人を抜き出し、更に残りから 1人を抜きだし、を繰り返しです。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
%!PS

/Kuji { % n m Kuji [numbers]
    [ 3 1 roll
    [
        1 1 5 -1 roll { } for
        dup 2 add -1 roll
        {
            counttomark dup rand exch mod roll
            counttomark 1 add 1 roll
        } repeat
    ] pop
    ]
} bind def

% ----- Test Code ---------
100 20 Kuji ==
コメントの削除 (Nested Flatten)

言語仕様的には PostScript では%以降がコメントになります。 ただしプリンタや処理系によってはコメント中の情報を用いて処理をする場合があります...

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
%!PS

/Decomment { % (filename) Decomment -
    true exch
    (r) file
    {
        % outputflag file
        dup read
        not { exit } if
        dup 37 eq {
            3 -1 roll pop false 3 1 roll
        } if
        dup dup 10 eq exch 13 eq or {
            3 -1 roll pop true 3 1 roll
        } if
        2 index {
            ( ) dup 0 4 -1 roll put
            print
        } {
            pop
        } ifelse
    } loop
    pop pop
} bind def

%---- Test Code ----
(decomment.ps) Decomment
格子点の列挙 (Nested Flatten)

力技で.. Bubble Sort したら遅かったので無理矢理 Quick Sort を実装。まだ荒削りですが。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
%!PS

/CompareVal { % [R X Y Theta] [R2 X2 Y2 Theta2 ] CompareXY  integer
    2 copy 0 get exch 0 get sub
    dup 0 eq
    {
        pop
        3 get exch 3 get sub
    } {
        exch pop exch pop
    } ifelse
    neg
} bind def

/QSort { %  [Array] /CompareFunction  QSort  [Array']
    cvx
    1 index 0 get
    0 3 index length 1 sub
    % [Array] Comp pivot l r
    {
        2 copy ge { exit } if 
        {
            2 copy ge { exit } if
            4 index 1 index get 3 index 5 index
            exec 0 lt { exit } if
            1 sub
        } loop
        2 copy ne {
            4 index 1 index get
            5 index exch 3 index exch put
            exch 1 add exch
        } if
        {
            2 copy ge { exit } if
            4 index 2 index get 3 index 5 index exec 0 gt { exit } if
            exch 1 add exch
        } loop
        2 copy ne {
            4 index 2 index get
            5 index exch 2 index exch put
            1 sub
        } if
    } loop
    4 index 2 index 4 index put 
    1 index 1 gt {
        4 index 0 3 index getinterval
        4 index QSort pop
    } if
    % [Array] Comp pivot l r
    4 index length 1 index 2 add gt {
        4 index dup length 3 index sub 1 sub  3 index 1 add exch getinterval
        4 index
        QSort pop
    } if
    pop pop pop pop
} bind def


/GenLattice { % N  GenLattice  [ [r^2 x1 y1 angle] ... ]
    [ exch
    2 div sqrt 1 add cvi
    dup neg exch 1 exch
    % [ -X0 1 X0 
    3 copy {
        % [ -X0 1 X0 Y
        4 copy pop {
            % [ -X0 1 X0 Y X
            2 copy [ 3 1 roll
            % [ -X0 1 X0 Y X  [ Y X
            2 copy dup mul exch dup mul add sqrt
            3 1 roll
            2 index 0 eq { 0 } { 2 copy atan } ifelse
            ]
            % [ -X0 1 X0 Y X  [ r^2 Y X theta ]
            6 1 roll pop
            % [ [] -X0 1 X0 Y 
        } for
        pop
    } for
    pop pop pop ]
} bind def

/DisplayLatticePoints { % N  DisplayLatticePoints  -
    dup GenLattice /CompareVal QSort
    0 1 4 -1 roll
    {
        1 index exch get aload pop pop
        10 string cvs print (, ) print =
        pop
    } for
    pop
} bind def

1000 DisplayLatticePoints
ミリ秒まで含んだ時刻文字列 (Nested Flatten)

PostScript では realtime オペレータで現在時刻を取り出せるのですが、なんと原点(0)がいつを指すかは未定義です。 そのため、別途パラメータで補ってやる必要があります。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
%!PS

/ZeroNum { % integer (string) ZeroNum (string')
    dup dup length dup string
    5 -1 roll exch cvs dup length
    3 -1 roll sub neg exch putinterval
} bind def

/GetClock { %
    % Input
    %   Offset1(YYYYMMDD in int)
    %   Offset2(offset for realtime clock to 00:00:00.000 in millisec)
    % Output
    %    (String)
    (YYYYMMDD000000.000) dup 0 8 getinterval 4 -1 roll exch ZeroNum pop
    exch
    realtime 86400000 mod add 86400000 add 86400000 mod
    dup 1000 mod  2 index 15 3 getinterval ZeroNum pop 1000 idiv 
    dup 60 mod 2 index 12 2 getinterval ZeroNum pop 60 idiv
    dup 60 mod 2 index 10 2 getinterval ZeroNum pop 60 idiv
    1 index 8 2 getinterval ZeroNum pop
} bind def

% ========= Test Code ============
20080616 32940000 GetClock ==
コード中の文字の頻度分析 (Nested Flatten) 
PostScript で... 
自分自身を食わせると 
32 ( ) 293
10 [*] 61
101 (e) 51
114 (r) 48
116 (t) 47
111 (o) 42
112 (p) 34
くらいで、roll, copy, exch あたりのスタック操作命令が結構稼いでいるかと思います。
(t はコメントと変数名が...)
一般的な PostScript File の傾向は.... あまりに傾向が散らばりすぎてよくわかりません。
例えば PhotoShop で作成した巨大bitmap の eps file などでは、
コードよりも圧倒的に多量の embed されたデータが傾向を
決めることになってしまいます。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
%!PS

/CompareVal { % [I1 V1] [I2 V2] CompareXY [I1 V1] [I2 V2] V2-V1
    2 copy 1 get exch 1 get sub 
} bind def

/Sort { % [[x y] [x1 y1] Array Data ] {CompareFunction}  Sort [ArrayData]
    cvx [ 3 -1 roll
    aload length
    % func -mark[- [] [] [] [] [] len
    -1 2 { % func -mark[- [] [] [] [] [] len2
        -1 2 {
            3 1 roll
            counttomark 1 add index exec  %% Compare
            0 lt { exch } if
            3 -1 roll
            1 roll
        } for
        counttomark 1 roll
    } for
    counttomark 1 roll
    ] exch pop
} bind def


/CountLetters {
    [ 0 1 255 { [ exch 0 ] } for ]
    {
        dup 2 index read
        {
            % array code
            get dup 1 get 1 add 1 exch put
        } {
            exit
        } ifelse
    } loop
    /CompareVal Sort
    exch pop exch pop
} bind def


/PrintResult {
    0 1 255 {
        2 copy get
        % [Array] i [I V]
        dup 0 get dup dup dup 3 string cvs print ( ) print
        32 ge exch 127 lt and {
            % [Array] i [I V] I 
            (( ) ) dup 1 4 -1 roll put print
        } {
            ([*] ) print
            pop
        } ifelse
        1 get =
        pop 
    } for
    pop
} bind def

%(countletter2.ps) (r) file CountLetters
(%stdin) (r) file CountLetters
PrintResult
next >>

Index

Feed

Other

Link

Pathtraq

loading...
Creative Commons License このサイトの内容は、 クリエイティブ・コモンズ・ライセンスの下でライセンスされています。 [詳細]