fork download 
  1. (defparameter SP "　" "U+3000 IDEOGRAPHIC SPACE")
  2. ;; (defparameter SP " ") ;半角幅のフォントで表示する場合
  3.  
  4. (defun read-pattern (stream
  5.                      &key (square-char #\#)
  6.                           (space-char #\.))
  7.   (loop for line = (read-line stream nil)
  8.         while (and line
  9.                    (> (length line) 0))
  10.         collect (mapcar (lambda (c)
  11.                           (cond ((char= c square-char)
  12.                                  #\#)
  13.                                 ((char= c space-char)
  14.                                  #\.)
  15.                                 (t
  16.                                  (error "invalid character: ~S" c))))
  17.                         (coerce line 'list))))
  18.  
  19. (let ((input-stream *standard-input*))
  20.   (loop for pattern = (read-pattern input-stream :square-char #\#
  21.                                                  :space-char #\.)
  22.         while pattern
  23.         do (let* ((w (length (car pattern)))
  24.                   (h (length pattern))
  25.                   (S (make-array (list h w) :initial-contents pattern))
  26.                   (L (make-array (list (- (* h 3) (- h 1))
  27.                                        (- (* w 3) (- w 1)))
  28.                                  :initial-element SP)))
  29.              (flet ((rep (y1 x1 y2 x2 c1 c2 r1 r2)
  30.                       (when (and (eql (aref L y1 x1) c1)
  31.                                  (eql (aref L y2 x2) c2))
  32.                         (or (when r1 (setf (aref L y1 x1) r1))
  33.                             (when r2 (setf (aref L y2 x2) r2))))))
  34.                (loop for sy from 0 upto (1- (array-dimension S 0))
  35.                      for y = (- (* sy 3) sy)
  36.                      do (loop for sx from 0 upto (1- (array-dimension S 1))
  37.                               for x = (- (* sx 3) sx)
  38.                               do (when (eql (aref S sy sx) #\#)
  39.                                    (setf (aref L (+ y 0) (+ x 0)) #\┌)
  40.                                    (setf (aref L (+ y 0) (+ x 1)) #\┬)
  41.                                    (setf (aref L (+ y 0) (+ x 2)) #\┐)
  42.                                    (setf (aref L (+ y 1) (+ x 0)) #\├)
  43.                                    (setf (aref L (+ y 1) (+ x 1)) #\┼)
  44.                                    (setf (aref L (+ y 1) (+ x 2)) #\┤)
  45.                                    (setf (aref L (+ y 2) (+ x 0)) #\└)
  46.                                    (setf (aref L (+ y 2) (+ x 1)) #\┴)
  47.                                    (setf (aref L (+ y 2) (+ x 2)) #\┘))))
  48.                (loop for ly from 0 upto (1- (array-dimension L 0)) do
  49.                  (loop for lx from 0 upto (1- (array-dimension L 1)) do
  50.                    (when (<= (1+ lx) (1- (array-dimension L 1)))
  51.                      (or (rep ly lx ly (+ lx 1) #\┐ #\┴ #\┼ #\┼)
  52.                          (rep ly lx ly (+ lx 1) #\┬ #\┌ nil #\┬)
  53.                          (rep ly lx ly (+ lx 1) #\┴ #\┌ nil #\┴)
  54.                          (rep ly lx ly (+ lx 1) #\┴ #\└ nil #\┴)
  55.                          (rep ly lx ly (+ lx 1) #\┼ #\┌ nil #\┼)
  56.                          (rep ly lx ly (+ lx 1) #\┼ #\├ nil #\┼)))
  57.                    (when (<= (1+ ly) (1- (array-dimension L 0)))
  58.                      (or (rep ly lx (1+ ly) lx #\┼ SP #\┴ nil)
  59.                          (rep ly lx (1+ ly) lx #\┼ #\┬ nil #\┼)
  60.                          (rep ly lx (1+ ly) lx #\├ #\┌ nil #\├)
  61.                          (rep ly lx (1+ ly) lx #\┤ #\┐ nil #\┤)
  62.                          (rep ly lx (1+ ly) lx #\┴ #\├ #\┼ nil)))
  63.                    (princ (aref L ly lx)))
  64.                  (terpri))))
  65.         when (listen input-stream)
  66.           do (write-line "--------------------------------------------------")))
  67.  
Success #stdin #stdout 0s 203840KB
comments (?)
stdin 
#

.#

.
#

#.
.#

#..###.####.
..#.....##.#
#.#....#.#.#
....#.#...#.

############
############
############
############
stdout 
┌┬┐
├┼┤
└┴┘
--------------------------------------------------
　　┌┬┐
　　├┼┤
　　└┴┘
--------------------------------------------------
　　　
　　　
┌┬┐
├┼┤
└┴┘
--------------------------------------------------
┌┬┐　　
├┼┤　　
└┴┼┬┐
　　├┼┤
　　└┴┘
--------------------------------------------------
┌┬┐　　　┌┬┬┬┬┬┐　┌┬┬┬┬┬┬┬┐　　
├┼┤　　　├┼┼┼┼┼┤　├┼┼┼┼┼┼┼┤　　
└┴┘　┌┬┼┴┴┴┴┴┘　└┴┼┼┼┼┼┴┼┬┐
　　　　├┼┤　　　　　　　　　├┼┼┼┤　├┼┤
┌┬┐　├┼┤　　　　　　　┌┬┼┴┼┼┤　├┼┤
├┼┤　├┼┤　　　　　　　├┼┤　├┼┤　├┼┤
└┴┘　└┴┘　┌┬┐　┌┬┼┴┘　└┴┼┬┼┴┘
　　　　　　　　├┼┤　├┼┤　　　　　├┼┤　　
　　　　　　　　└┴┘　└┴┘　　　　　└┴┘　　
--------------------------------------------------
┌┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┬┐
├┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┤
├┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┤
├┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┤
├┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┤
├┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┤
├┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┤
├┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┼┤
└┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┴┘
https://ideone.com/kzHGwq
language:
Common Lisp (sbcl 1.4.16)
created:
6 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!