Name: Anonymous 2009-07-27 14:50
I wrote some actual programmes when you were down. Please don't leave me again.
openTag s = "[" ++ s ++ "]"
closeTag s = openTag ('/':s)
surround s t = openTag s ++ t ++ closeTag s
-- Too lazy to use TH
[sup, sub, code, b, i, spoiler, o, u, s] =
map surround ["sup", "sub", "code", "b", "i", "spoiler", "o", "u", "s"]
tacnoc = map (:[])
crack f = concat . f . tacnoc
rev f = reverse . f . reverse
dowords f = unwords . f . words
(->!) = zipWith ($)
clamour = b . i . o . u
loveyourpost = unwords $ [b, i, o, u] ->!
lines "I LOVE YOU!\nI LOVE YOUR POST!\nI READ IT FIVE TIMES!\nKEEP POSTING!"
-- Check your length!
zipLines top bot a b = concat fin -- French
where fin = zipWith (++) topped bottomed
topped = map top (tacnoc a)
bottomed = map bot (tacnoc b)
(a', b') = fixl (a, b)
fixl ([], xs) = (cycle " ", xs)
fixl (xs, []) = (xs, cycle " ")
fixl (x:xs, y:ys) = let (xs', ys') = fixl (xs, ys) in (x:xs', y:ys')
dotagr t = t . foldr1 (\l r -> l ++ t r)
dotagl t = t . foldl1 (\l r -> t l ++ r)
deal tag [] = []
deal tag ws
| length ws < 3 = tag ws
| otherwise = tag ws'
where wa = head ws
wz = last ws
mid = take (length ws - 2) $ tail ws
ws' = (wa :) $ deal tag mid ++ [wz]
deal2 t s = dotagr t sl ++ dotagl t sr
where ln = length s `div` 2
sl = take ln s
sr = drop ln s
bbcode = b $ sup "B" ++ sub "B" ++ "Code"
say = putStrLn(define (rhombus m)
;;Needs to be optimized to remove the redundant tags
;;Also use special cases of skew(left|right) so that first element is ignored
(let ((message (split m)))
(string-append (skew-left sup message)
(skew-right sup message)
br
(skew-left sub message)
(skew-right sub message))))
(define (circlejerk format-list sentence)
(define fl (list->mlist format-list))
(set-mcdr! (mlast-pair fl) fl) ;make list circular XD
(let loop ((f fl) (l (split sentence)))
(if (null? l)
""
(string-append ((mcar f) (car l))
" "
(loop (mcdr f) (cdr l))))))
>(circlejerk (list b i o u) "This is one shitty thread if you know what I mean ;)")(define (list-split l pos)
(if (< pos 0)
(error "pos not a non-negative integer")
(let ((head '()))
(let loop ((tail l) (index pos))
(cond ((= index 0) (list (reverse head)
tail))
((null? tail) (error "List not long enough"))
(else
(set! head (cons (car tail) head))
(loop (cdr tail) (- index 1))))))))
(define (takeh n xs)
(if (or (null? xs) (<= n 0)) '()
(cons (car xs) (take (- n 1) xs))))
(define (droph n xs)
(if (or (null? xs) (<= n 0)) xs
(drop (- n 1) xs)))
(define (split-at n xs)
(cons (takeh n xs) (droph n xs)))take and drop in recursive calls instead of takeh and droph. You can fix that, though.
module Main
where
import List
openTag b = "[" ++ b ++ "]"
closeTag b = openTag ('/':b)
tag b t = openTag b ++ t ++ closeTag b
tags = map tag ["b", "i", "u", "o"]
ctags = cycle tags
bbcode s = concat $ intersperse " " $ zipWith ($) ctags (words s)
(define (takeh n xs)
(if (or (null? xs) (<= n 0)) '()
(cons (car xs) (takeh (- n 1) (cdr xs)))))
(define (droph n xs)
(if (or (null? xs) (<= n 0)) xs
(droph (- n 1) (cdr xs))))
(define (split-at n xs)
(list (takeh n xs) (droph n xs)));This is me just being nitpicky though cons is finelist where you put cons, so you can map over the result. Also, you need to use more verbose names for your functions, like haskell-style-take
/prog/
(,), and I forgot to test it before I posted :c
(define omg-sine
(λ(string)
(let* ((duplicate (λ(string n) (let L ((accum "")
(n n))
(if (zero? n)
accum
(L (string-append accum string) (- n 1))))))
(next-tag (λ(last-height current-height)
(if (= last-height current-height)
empty
(string->list (duplicate (if (positive? (+ last-height current-height))
(if (> last-height current-height) "[/sup]" "[sup]")
(if (< last-height current-height) "[/sub]" "[sub]"))
(abs (- last-height current-height)))))))
(normalized-sine ((λ(n) (λ(x) (inexact->exact (round (* n (sin (/ (* x pi) n))))))) 10)))
(let L ((accum empty)
(list (string->list string))
(last-height 0)
(position 0))
(if (empty? list)
(list->string (append accum (next-tag last-height 0)))
(let ((current-height (normalized-sine position)))
(L (append accum (next-tag last-height current-height) (cons (car list) empty))
(cdr list)
current-height
(+ position 1))))))))