пятница, 25 марта 2011 г.

Проблема К

На лямбда-планете сейчас модно решать сабж. Вот лисповое решение:

(defvar *table*)

(declaim (ftype function solve-expression)
         (ftype function parse-expression))

(defmacro get-cell (col line)
  `(cdr (assoc ,col (cadr (assoc ,line *table*)) :test #'equal)))

(defun digit? (char)
  (<= (char-code #\0) (char-code char) (char-code #\9)))

(defun op? (char)
  (member char '(#\+ #\- #\* #\/)))

(defun alpha? (char)
  (<= (char-code #\A) (char-code char) (char-code #\Z)))

(defmacro sequence-to-string (seq)
  `(map 'string #'identity ,seq))

(defmacro read-char-of-type (type f)
  `(loop for char = (peek-char nil ,f nil)
      while (and char (,type char))
      collect (read-char ,f)))

(defun read-integer (f)
  (parse-integer
   (sequence-to-string
    (read-char-of-type digit? f))))

(defun read-ref (f)
  (list
   (sequence-to-string (read-char-of-type alpha? f))
   (parse-integer (sequence-to-string (read-char-of-type digit? f)))))

(defun column-number-to-string (n)
  (labels ((foo (n)
             (when (plusp n)
               (multiple-value-bind (quo rem)
                   (truncate (1- n) 26)
                 (append (foo quo) (list rem)))))
           (map-num (n)
             (code-char (+ (char-code #\A) n))))
    (map 'string #'map-num (foo n))))

(defun read-cell (f)
  (sequence-to-string
   (loop for char = (read-char f nil)
      while (and char (not (member char '(#\Tab)))) collect char)))

(defun read-table (f)
  (let (*read-eval*)
    (with-input-from-string (f1 (read-line f))
      (let* ((lines (read f1))
             (columns (read f1)))
        (list lines columns
              (loop for line from 1 to lines
                 for data = (read-line f)
                 unless (equal data "")
                 collect (list line
                               (with-input-from-string (f data)
                                 (loop for column from 1 to columns
                                    collect (list (column-number-to-string column)
                                                  :data (read-cell f)
                                                  :cycle nil :value nil))))))))))

(defmacro aif (test-form then-form &optional else-form)
  `(let ((it ,test-form))
     (if it ,then-form ,else-form)))

(defun solve-cell (cell)
  (aif (getf cell :value)
      it
      (let ((cycle? (getf cell :cycle)))
        (setf (getf cell :cycle) t
              (getf cell :value) (if cycle?
                                     "#cycle"
                                     (let ((data (getf cell :data)))
                                       (typecase (read-from-string data)
                                         (integer (parse-integer data))
                                         (list (subseq data 1))
                                         (t (solve-expression (subseq data 1))))))))))

(defun deref! (exp)
  (cond
    ((integerp exp) exp)
    ((listp exp) (solve-cell (get-cell (car exp) (cadr exp))))))

(defun solve-expression (data)
  (handler-case
      (loop with exp = (parse-expression data)
         with lvar = (deref! (pop exp))
         for op = (pop exp)
         for rvar = (pop exp)
         while (and op rvar)
         do (let ((rvar! (deref! rvar)))
              (setf lvar (case op
                           (#\+ (+ lvar rvar!))
                           (#\- (- lvar rvar!))
                           (#\* (* lvar rvar!))
                           (#\/ (mod lvar rvar!)))))
         finally (return lvar))
    (error (c)
      (format nil "#arith ~a" c))))

(defun parse-expression (data)
  (with-input-from-string (f data)
    (loop for char = (peek-char nil f nil)
       while char
       collect
         (cond
           ((digit? char) (read-integer f))
           ((op? char) (read-char f))
           ((alpha? char) (read-ref f))
           (t (loop-finish))) into ret
       finally (return ret))))

(destructuring-bind (lines columns *table*)
    (read-table *standard-input*)
  (loop
     for y from 1 to lines do
       (loop
          for x1 from 1 to columns
          for x = (column-number-to-string x1)
          for cell = (get-cell x y)
          do (format t "~a~,8T" (solve-cell cell)))
       (write-char #\Newline)))

;
SBCL его жуёт:
$ sbcl --load k.lisp < input
This is SBCL 1.0.46, an implementation of ANSI Common Lisp.
More information about SBCL is available at .

SBCL is free software, provided as is, with absolutely no warranty.
It is mostly in the public domain; some portions are provided under
BSD-style licenses.  See the CREDITS and COPYING files in the
distribution for more information.
12       -4      3       Sample  
4        -16     -4      Spread  
Test     1       5       Sheet  
Решение в лоб, неоптимизированное, ошибки не ловит практически, комменты расставлять лень. Ну и красивостей можно в коде навести, да.

2 комментария:

  1. Да я случайно запостил на лямбда-планету тот старый пост -- подредактировал его, а он раз -- и появиля на планете о_О

    Но за решение спасибо, любопытно )

    ОтветитьУдалить
  2. Нда, таки надо было спать идти... ;) А то после работы, красными квадратными глазами увиделся целый флешмоб.

    ОтветитьУдалить

Архив блога