良し悪しは置いといて、懲りずに問題を作りました。

自分で作って、自分で解くのに苦労。。。
投稿したら、20分後に別の人が投稿してた。。。

そんなに簡単っすか。。。

ということで、投稿したコードは以下の通り。
zipWith を使いこなせば、100は切れそうだ。

【初稿】 145 バイト

f n=[1..n]>>"*"
a n|n>25=25|1>0=n
b n=drop(30-n)"apple"++f(a n)++take(30-n)"apple"++f(25-n)
main=do n<-readLn;mapM putStrLn[b$k`mod`30|k<-[0..n]]

【修正後1】 110 バイト

f=[1..25]>>"*"
a="apple"
l=a++f++a++f
main=readLn>>=(\n->mapM putStrLn[take 30$drop(k`mod`30)l|k<-[n,n-1..0]])

【修正後2】 103 バイト：問題文の入力規則が悪く、趣旨を外れても正解に。。。

f=[1..25]>>"*"
l="apple"++f
main=readLn>>=(\n->mapM putStrLn[take 30$drop(k`mod`30)l++l|k<-[n,n-1..0]])

【修正後3】 101 バイト: 大分きれいになった。

l="apple"++replicate 25'*'
main=readLn>>=(\n->mapM putStrLn[take 30$drop(30-k`mod`30)l++l|k<-[0..n]])

【修正後4】 100 バイト: もう縮まない。。。

l="apple"++([1..25]>>"*")
main=readLn>>=(\n->mapM putStrLn[take 30$drop(30-k`mod`30)l++l|k<-[0..n]])

【修正後5】 94 バイト: 縮むと分かるとまだやれるもんだ。。。

f l=last l:init l
main=do n<-readLn;mapM putStrLn$take(n+1)$iterate f("apple"++([1..25]>>"*"))

【修正後6】 94 バイト: interact を使ったが縮まらない。。。

f l=last l:init l
main=interact(\x->unlines$take(read x+1)$iterate f("apple"++([1..25]>>"*")))

【その他1】 106 バイト: これは駄目だった。。。

f 0l=l
f n l=f(n-1)(last l:init l)
main=do n<-readLn;mapM putStrLn[f k("apple"++([1..25]>>"*"))|k<-[0..n]]

【修正後7】 93 バイト: \\ の部分は1行で書いていることを示してます。

main=interact(\x->unlines$take(read x+1)$iterate(\l->last l:init l)\\
("apple"++([1..25]>>"*")))

【その他2】 98 バイト: reverse を試したが駄目だった。

f(x:s)=s++[x]
main=interact\\
(\x->unlines$reverse$take(read x+1)$iterate f("apple"++([1..25]>>"*")))