Latest comments for language 'PostScript' on doukaku.org

Nemo's comment on 漢数字で九九の表

PostScript で。

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

%!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} として 定義する
/漢数字変換 は {
  コピーし て 十 で割った余り を 漢数字 と 入れ替え て 番目を取り出す
  入れ替え て
  もし コピーし て 十 以上 であったら
  {
      十 で 割り 漢数字 と 入れ替え て 番目を取り出す
  } を実行し、さもなくば
  {
      捨てる
      (　) % 全角空白
  } をかわりに実行する
} として 定義する


一 から 一 づつ 九 まで {
    一 から 一 づつ 九 まで {
    二 番目をコピー して 掛け
        漢数字変換 して 出力する 出力する ( ) を 出力する
    } を 指定回数繰り返す
    捨てる
    改行する
} を 指定回数繰り返す

[ PostScript ] [ download code ] ]

Nemo's comment on 文字列型日時ののN秒後時間取得

文字列型日時のの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) (うるう秒)

%!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 ==

[ PostScript ] [ download code ] ]

匿名's comment on LL Golf Hole 2 - 文字列に含まれる単語の最初の文字を大文字にする

LL Golf Hole 2 - 文字列に含まれる単語の最初の文字を大文字にする (Nested Flatten)

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

[(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 ] [ download code ] ]

匿名's comment on LL Golf Hole 2 - 文字列に含まれる単語の最初の文字を大文字にする

LL Golf Hole 2 - 文字列に含まれる単語の最初の文字を大文字にする (Nested Flatten)

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

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

[(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

[ PostScript ] [ download code ] ]

匿名's comment on 環境変数の取得

環境変数の取得 (Nested Flatten)

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

%!PS

(PATH) getenv { = } if

% ========= Cut Here ===========
%!PS
currentdict { === } forall

[ PostScript ] [ download code ] ]

Nemo's comment on コード圧縮

コード圧縮 (Nested Flatten)

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

%!PS

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

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

% ======== 以下出力結果
% {1 3 roll 10 add (abc%Hoge) == ==}

[ PostScript ] [ download code ] ]

Nemo's comment on 比較しないソートの作成

比較しないソートの作成 (Nested Flatten)

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

%!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 ==

[ PostScript ] [ download code ] ]

Nemo's comment on 設定ファイルから値を取得

設定ファイルから値を取得 (Nested Flatten)

普通 PostScript ではプリンタ依存性が大きくなるので外部ファイルの読み込みをユーザープログラムでやることはないと思います。
ここでは GhostScript で試しています。

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

%!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

[ PostScript ] [ download code ] ]

Nemo's comment on コメントの削除

コメントの削除 (Nested Flatten)

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

%!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

[ PostScript ] [ download code ] ]

Nemo's comment on n人中m人が当選するくじ

n人中m人が当選するくじ (Nested Flatten)

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

%!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 ==

[ PostScript ] [ download code ] ]

Nemo's comment on コメントの削除

コメントの削除 (Nested Flatten)

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

%!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

[ PostScript ] [ download code ] ]

Nemo's comment on 格子点の列挙

格子点の列挙 (Nested Flatten)

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

%!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

[ PostScript ] [ download code ] ]

Nemo's comment on ミリ秒まで含んだ時刻文字列

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

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

%!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 ==

[ PostScript ] [ download code ] ]

Nemo's comment on コード中の文字の頻度分析

コード中の文字の頻度分析 (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 されたデータが傾向を
決めることになってしまいます。

%!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

[ PostScript ] [ download code ] ]

Nemo's comment on 文字列のセンタリング

文字列のセンタリング (Nested Flatten)

PostScript で。 PostScript で文字数単位でやる実用性はほとんど無いでしょうね。通常はフォント指定して文字列幅を計算、幅にあわせて切り捨てるなり圧縮するなり、でしょうから。

%!PS

/FillSpace { % (String) FillSpace (String')
    dup length 1 sub 0 1 3 -1 roll {
        1 index exch 32 put
    } for
} bind def

/Centering { % (String) length Centering (NewString)
    dup string FillSpace dup
    3 index length 4 -1 roll
    2 copy le {
        sub neg 2 idiv 4 -1 roll putinterval
    } {
        2 copy sub 2 idiv 
        exch 6 -1 roll 3 1 roll getinterval
        exch pop 0 exch putinterval
    } ifelse
} bind def

% -------------------- Test Code ------------------
(ABC) 10 Centering ==
(ABCDEF) 10 Centering ==
(ABCDEF) 3 Centering ==
(ABCDEF) 6 Centering ==

[ PostScript ] [ download code ] ]

Nemo's comment on 循環関数

循環関数 (Nested Flatten)

PostScript です。 50% のカバレッジを目指しているのですが、なかなか...

!PS

/modular { % n low high  modular  result
    1 index sub 1 add 3 -1 roll 1 index mod
    dup 0 lt { add } { exch pop } ifelse add
} bind def

% --- Test Code ---
0 100 200 modular =
50 100 200 modular =
100 100 200 modular =
101 100 200 modular =
-1 100 200 modular =
1 -5 200 modular =
-500 -5 -1 modular =

[ PostScript ] [ download code ] ]

Nemo's comment on 出力の一時停止と再開

出力の一時停止と再開 (Nested Flatten)

無謀にも PostScript で。 GhostScript 7.07 のファイル関連のオペレーターのbug だか仕様だかに泣かされました...

どうにもならなかったので ghostscript 2本並列実行で文字入力と表示を役割分担しています。プロセス間通信は名前付きファイルで... 激しくファイルの open/close をしますので実用的ではありません。

%% Terminal 1
%   stty raw < /dev/tty
%   gs -sDEVICE=nullpage echoback.ps 

%% Terminal 2
%   gs -sDEVICE=nullpage pause.ps 

%------------------ echoback.ps ----- Cut Here ---------
%!PS

/Stdin (%stdin) (r) file def
(/tmp/test) (w) file closefile

% p: 112, q: 113
{
    Stdin read
    {
        (/tmp/test) (w) file dup 2 index write closefile
        113 eq { exit } if
    } {exit} ifelse
} loop
quit



%--------------------  pause.ps ------  Cut Here  ---------
%!PS

/Sleep { % OutputFlag Timer  Sleep   OutputFlag'
    realtime
    {
        realtime 1 index sub
        2 index ge {exit} if
        (/tmp/test) (r) file dup read 
        {
            exch closefile (/tmp/test) (w) file exch
            dup 113 eq { quit } if
            112 eq { 4 -1 roll not 4 1 roll } if
        } if
        closefile
    } loop
    pop
    pop
} def


true 
{
    1000 Sleep
    dup {(a) print flush} if
} loop

[ PostScript ] [ download code ] ]

Nemo's comment on METHINKS IT IS A WEASEL

METHINKS IT IS A WEASEL (Nested Flatten)

PostScript で素直に実装してみたのですが、なかなか収束しないので皆さんと同様、 5個のバリエーションを生成、元の文字列も残す方向です。

%!PS
% ---- Parameters ----------------------------------
/String (ABCDEFGHIJKLMNOPQRSTUVWXYZ) def
/Target (METHINKSITISAWEASEL) def
/NumStrings 300 def
/NumMutations 5 def
/Keep true def
% ---------------------------------------------------


/TargetLength Target length def
/StringLength String length def


/RandomLetter {
    String rand StringLength mod get
} bind def

/Diff { % (TargetString) (string) Diff  (TargetString) (string)  integer
    0
    0 1 TargetLength 1 sub {
    % (str) (tar) sum count
    dup 4 index exch get
    % (str) (tar) sum count  let
    exch 3 index exch get
    % (str) (tar) sum count  let let2
%    sub abs add   
%    sub dup mul add   
    sub 0 ne { 1 add } if
    } for
} bind def


/GenStrings { % NumStrings TargetLength GenStrings [(String1) ... (String N)]
    exch
    [ 3 1 roll
    % [ Len Num
    {
        % [ Len
        dup dup string exch
        % [ Len (Str) Len
        0 1 3 -1 roll 1 sub {
        % [ Len (Str) count
        1 index exch RandomLetter put
        } for
        exch
    } repeat
    pop
    ]
} bind def

/CalcDistance { % (TargetString) (String) CalcDistance (Target) [dist (str)]
    Diff exch 2 array astore
} bind def

/Sort { % [[x y] [x1 y1] Array Data ] Sort [ArrayData]
    [ exch
    aload length
    % func -mark- [] [] [] [] [] len
    -1 2 { % func -mark- [] [] [] [] [] len2
    -1 2 {
        3 1 roll
        2 copy 0 get exch 0 get sub
        0 gt { exch } if
        3 -1 roll
        1 roll
    } for
    counttomark 1 roll
    } for
    counttomark 1 roll
    ] 
} bind def

/Mutation { % (String)  Mutation  (String')
    dup dup length rand exch mod RandomLetter put
} bind def



NumStrings TargetLength GenStrings
[ exch Target exch {
    CalcDistance exch
} forall pop ]
Sort

{
[ exch {
    1 get
    % (str)
    NumMutations {
    % (str) (str') (str') 0
    dup length string dup 0 3 index putinterval
    Mutation
    } repeat
    Keep not { NumMutations 1 add -1 roll pop } if
} forall ]
[ exch Target exch {
    CalcDistance exch
} forall pop ]
Sort
0 NumStrings getinterval
dup 0 get dup == flush
0 get 0 eq {quit} if
} loop

[ PostScript ] [ download code ] ]

Nemo's comment on マルバツゲーム

マルバツゲーム (Nested Flatten)

あんまり綺麗なコードじゃないですが、 PostScript で。

O win : 5892
draw  : 1247
X win : 2861

%!PS

/ShowMap { % [Map Vector]  ShowMap  -
    aload length sqrt cvi
    dup { % v0 v1 ... vn N
        dup { % v0 v1 ... vn N
            exch dup
            0 gt { pop (O) } { 0 lt { (X) } { ( ) } ifelse } ifelse
            print
        } repeat
        () =
    } repeat
    pop
    () =
} bind def

/DotProduct { % [Vector1] [Vector2]  DotProduct scaler
    [ 3 1 roll
    dup length 1 sub 0 1 3 -1 roll {
        3 copy get 3 1 roll exch get mul 3 1 roll
    } for
    pop pop
    ]

    0 exch
    { add } forall
} bind def

/CheckerVector [
        [ 1 1 1 0 0 0 0 0 0 ]
        [ 0 0 0 1 1 1 0 0 0 ]
        [ 0 0 0 0 0 0 1 1 1 ]
        [ 1 0 0 1 0 0 1 0 0 ]
        [ 0 1 0 0 1 0 0 1 0 ]
        [ 0 0 1 0 0 1 0 0 1 ]
        [ 1 0 0 0 1 0 0 0 1 ]
        [ 0 0 1 0 1 0 1 0 0 ]
    ] def

/KachiMake { % [Map Vector]  KachiMake   integer
    dup length sqrt cvi 0 exch
    CheckerVector
    {
        % [Map] 0 N [V]
        3 index DotProduct
        dup
        % [Map] 0 N V V
        2 index eq {
            pop pop 1 exch exit
        } {
            % [Map] 0 N V
            1 index neg eq {
                pop -1 exch exit
            } if
        } ifelse
    } forall
    pop exch pop
} bind def


/Okeru { % [Map] Okeru [Okeru]
    [ exch dup length 1 sub
    0 1  3 -1 roll
    {
        2 copy get 0 eq {
            exch
        } {
            pop
        } ifelse
    } for
    pop
    ]
} bind def

/RandomPlayer { % [Map] player RandomPlayer [Map'] bool
    % player: -1 or 1
    exch dup dup 4 2 roll Okeru
    dup length dup
    0 gt {
        rand 1024 idiv exch mod
        get
        exch put true
    } {
        pop pop pop pop false
    } ifelse
} bind def

/Marubatsu { % [Map] int /Proc1 /Proc2 Marubatsu  int
    % Result: 0 : draw, 1: O win, -1: X win

    % Initial Table
    4 copy 2 index 1 lt {
        exch
    } if
    pop
    cvx exec
    {
        KachiMake dup 0 eq
        {
            pop
            3 -1 roll neg 3 1 roll
            Marubatsu
        } if
    } {
        pop 0
    } ifelse
} bind def

% Randmize
realtime srand

% Counter
[0 0 0]

10000 {
    [0 0 0 0 0 0 0 0 0] 1 /RandomPlayer /RandomPlayer Marubatsu
    5 1 roll pop pop pop
%    ShowMap
    pop
    1 add 2 copy 2 copy get 1 add put pop
} repeat

aload pop
(O win : ) print =
(draw  : ) print =
(X win : ) print =

[ PostScript ] [ download code ] ]

Nemo's comment on 変形Fizz-Buzz問題

変形Fizz-Buzz問題 (Nested Flatten)

PostScript で。
文字列処理はやっかいなので、素直に条件を満たしたら上書きで。

%!PS
1 1 20 {
    (hoge)
    1 index 3 mod 0 eq { pop (Fizz) } if
    1 index 5 mod 0 eq { pop (Buzz) } if
    1 index 15 mod 0 eq { pop (FizzBuzz) } if
    exch 10 string cvs print (:) print
    =
} for

[ PostScript ] [ download code ] ]