Полезные коды и авторские программы на Lisp

(defun ArabRim ()
(setf R (vector "M" "D" "C" "L" "X" "V" "I"))
(format t "Vvedite Arab = ")
(setf Arab (read))
(format t "Arab = ~A ==> Rim = " Arab)
(setf end (floor Arab 1000))
  (do ((i 1 (+ i 1)))
      ((> i end) 'done)
    (format t "M"))
  (do ((j 0 (+ j 1)))
      ((> j 2) 'done)
(setf s  (/ (- (mod Arab (expt 10 (- 3 j))) (mod Arab (expt 10 (- 2 j)))) (expt 10 (- 2 j))))
(setf I  (+ (* 2 j) 2))
(setf V  (+ (* 2 j) 1))
(setf X  (* 2 j))
(setf s1 (- s 5))
(cond ((= 0 s) (format t "" ))
      ((= 4 s)(format t "~A" (concatenate 'string (svref R I) (svref R V))))
      ((= 9 s)(format t "~A" (concatenate 'string (svref R I) (svref R X))))
      ((and (< 0 s) (< s 4))
       (do ((k 1 (+ k 1)))
         ((> k s) 'done)
         (format t "~A" (svref R I))))
      ((<= 0 s1) (format t "~A" (svref R V)) 
       (do ((l 1 (+ l 1)))
         ((> l s1) 'done)
         (format t "~A" (svref R I)))))))

(require '[clojure.string :as string])
 
(def flag 
  (atom 0)) 
(def flag-inside  
  (atom 0)) 
(def answer 
  (atom ""))
(def question 
  (atom ""))
(def hintFirst
  (atom ""))
(def hintSecond
  (atom ""))
(def hintThird
  (atom ""))
(def navigator
  (atom 1))
(def score
  (atom 0))
 
(defn PrintLogo []
 (println " __________________________________________________ ")
 (println "/___   | | |  | ||___  \\ |__   __| | ___  | | | / / ")
 (println " __ )  | | |__| |  __\\  \\   | |    | |  | | | |/ /  ")
 (println "(__  (   |  __  | / ___  \\  | |    | |  | | |   (   ")
 (println " ___)  | | |  | |( (___\\  \\ | |    | |__| | | |\\ \\  ")
 (println "\\______| |_|  |_| \\_______/ |_|    |______| |_| \\_\\ "))
 
 
 
 
;;;ИНИЦИАЛИЗАЦИЯ ПЕРЕМННОЙ PLAYERS
;;;******************************************************************************************************
(def players (read-string (slurp "/home/user/playersdb.txt")))
 
 
;;;ЧТЕНИЕ ВОПРОСОВ, ОТВЕТА И ПОДСКАЗОК ИЗ ФАЙЛА И ИНИЦИАЛИЗАЦИЯ СООТВЕТСТВУЮЩИХ АТОМОВ
;;;******************************************************************************************************
(defn ReadFile [file number]
  (with-open [reader (clojure.java.io/reader file)]  
    (doseq [init (line-seq reader)]
      (when (string/starts-with? number init)
        (doseq [line (take 6 (line-seq reader))]
          (cond
            (re-find  #"^Вопрос"       line) (reset! question line)
            (re-find  #"^Ответ"        line) (reset! answer  
                                                  (re-find #"[^Ответ: ].*" line))
            (re-find  #"^ПодсказкаРаз" line) (reset! hintFirst 
                                                  (re-find #"[^ПодсказкаРаз: ].*" line))
            (re-find  #"^ПодсказкаДва" line) (reset! hintSecond
                                                  (re-find #"[^ПодсказкаДва: ].*" line))
            (re-find  #"^ПодсказкаТри" line) (reset! hintThird 
                                                  (re-find #"[^ПодсказкаТри: ].*" line)))))))) 
;;;ФУНКЦИЯ УДАЛЕНИЕ ПРОБЕЛОВ
;;;*********************************************************************************************************
 
(defn RemoveSpace [string]
  (if (some #{\space} (seq string))
    (apply str (remove #{\space} (seq string)))
    string))
 
 
;;;ПОВЕРКА СОЗДАВАЕМОГО ПОРОЛЯ
;;;******************************************************************************************************
(defn TestPassword [keyname get-name]
 (print "Придумайте пароль: ")
 (flush)
 (let [get-password (read-line)]
   (cond
     (= get-password "выход") 
     "EXIT"
     (nil?
       (re-find #"[0-9]" 
                (str (re-matches #".*[a-z, A-Z].*" get-password))))
     (do
       (println "Пароль должен содержать буквы и цифры")
       (recur keyname get-name))
    (some #{\space} (seq get-password))
    (do
      (println "Пароль не должен сожержать пробелы")
      (recur keyname get-name))    
    (< (count get-password) 6)
    (do
      (println "Пароль должен быть не короче шести символов")
      (recur keyname get-name))
    :else 
    (do
      (spit "/home/lispo/playersdb.txt"
            (assoc players keyname (hash-map :name get-name :password (hash get-password) :navigator 1 :score 0 :hint 0)))
      (def nick get-name)      
      (println (format "%s, вы удачно зарегестрированы.", get-name))))))
 
 
;;;РЕГИСТРАЦИЯ ИГРОКА
;;;******************************************************************************************************
(defn RegPlayer []
 (print "Ваше имя для игры: ")
 (flush)
 (let [raw-name (read-line)
       get-name (RemoveSpace raw-name)
       keyname  (keyword get-name)]
   (cond 
     (= get-name "выход") 
     "EXIT"
     (and 
       (= "FREE" (keyname players "FREE"))
       (not (nil? (re-find #"^[a-z, A-z].*" get-name)))
       (>= (count get-name) 3)) 
       (TestPassword  keyname get-name)
     (not= "FREE" (keyname players "FREE"))
     (do 
       (println (format "Имя %s уже занято.", get-name))
       (recur))
     (nil? (re-find #"^[a-z, A-Z].*" get-name))
     (do
       (println "Имя должно начинаься с буквы.")
       (recur))
     (< (count get-name) 3)
     (do
       (println "Имя должно быть не короче трех символов.")
       (recur)))))
 
 
;;;ВНЕСЕНИЕ ИЗМЕНЕНИЙ В СТАТИСТИКУ ИГРОКА
;;;******************************************************************************************************
;;; Изменение данных игрока и запись их, в том числе при выходе из игры.
(defn ChangeData [nick navigator score flag flag-inside]
  (let [keyname     (keyword nick)
        players     (read-string (slurp "/home/lispo/playersdb.txt"))
        navigator   @navigator
        score       @score
        flag        @flag
        flag-inside @flag-inside
        password    ((comp :password  keyname) players)]
    (spit "/home/user/playersdb.txt"
          (assoc-in players [keyname] 
                    (hash-map :name nick :password password  :navigator navigator :score score :flag flag :hint flag-inside)))))
 
;;;Запись изменений при правильном ответе
(defn ChangeDataWhenAnswer [nick navigator score flag flag-inside]
  (cond
    (= 0 @flag-inside) 
    (do (swap! score + 8)
      (ChangeData nick navigator score flag flag-inside))
    (= 1 @flag-inside)
    (do (swap! score + 6)
      (ChangeData nick navigator score flag flag-inside))
    (= 2 @flag-inside)
    (do (swap! score + 4)
      (ChangeData nick navigator score flag flag-inside))
    (= 3 @flag-inside)
    (do (swap! score + 2)
      (ChangeData nick navigator score flag flag-inside))))                   
 
 
;;;ВХОДА В ИГРУ: ПРОВЕРКА ЛОГИНА И ПОРОЛЯ
;;;******************************************************************************************
(defn CheckLoginForEnter []
  (print "Логин: ")
  (flush)
  (let [raw-name (read-line)
        get-name (RemoveSpace raw-name)
        keyname  (keyword get-name)]
    (cond 
      (= get-name "выход")
      "EXIT"
      (not= "NOT_EXIST" (keyname players "NOT_EXIST")) 
      (def nick get-name)
      :default
      (do  
        (println "Неверный логин.")       
        (recur))))) 
 
(defn CheckPasswordForEnter  [nick]
  (print "Пароль: ")
  (flush)
  (let [console       (System/console)
        raw-password  (.readPassword console)
        password      (RemoveSpace (apply str raw-password))
        keyname       (keyword nick)]
    (cond 
      (= password "выход") 
      "EXIT"
      (= (hash password) ((comp :password keyname) players))
      (do 
        (println "Добро пожаловать," nick)
        (reset! navigator   ((comp :navigator keyname)  players))
        (reset! score       ((comp :score     keyname)  players))
        (reset! flag        ((comp :flag      keyname)  players))
        (reset! flag-inside ((comp :hint      keyname)  players)))
      :default 
      (do
        (println "Неверный пароль.")
        (recur nick)))))
                     
                       
(defn TestEnter []
  (if (= "EXIT" (CheckLoginForEnter))
    "EXIT"
    (CheckPasswordForEnter nick)))
 
 
;;;ПОЛУЧЕНИЕ СТАТИСТИКИ
;;;********************************************************************************************
;;;Stats  -- трансформация map players в vector, содержащий maps с основными данными играков.
(defn Stat [maps]
  (loop [maps maps
         target (vector)]
    (if (seq maps)
      (recur (into {} (rest maps)) (into target (vector (get-in (vec maps) [0 1]))))
      target)))
 
;;;StatsPrint -- вывод статистики на экран.
(defn StatPrint 
  ([]
    (let [prestat (Stat players)
          raw     (reverse (sort-by :score prestat))]
      (dotimes [iter (count raw)]
        (println iter"\b)"(:name (.get raw iter)) " баллы: " (:score (.get raw iter))))))
  ([number]
    (let [prestat (Stat players)
          raw     (reverse (sort-by :score prestat))]
      (dotimes [iter number]
        (println iter"\b)" (:name (.get raw iter)) " баллы: " (:score (.get raw iter)))))))
 
(defn PersonalStat []
  (let [prestat (Stat players)
        raw     (reverse (sort-by :score prestat))]
        (dotimes [iter (count players)]
          (when (= (:name (.get raw iter)) nick)
            (println iter"\b)" (:name (.get raw iter)) " баллы: " (:score (.get raw iter)))))))
 
 
 
;;;Получение статистики из меню.
(defn GetStatFromLauncher [players]
  (if (>= (count players) 10)
    (StatPrint 10)
    (StatPrint))
  (let [get-key (read-line)]
    (when-not get-key)))
 
 
;;;ВНУТРЕНИИЙ ЦИКЛ ДЛЯ ПОДСКАЗОК
;;;*************************************************************************************************
(defn HintLoop [inner-counter]
  (print "Введите да или нет: ")
  (flush)
  (let [gets (string/lower-case (read-line))]
    (cond    
      (= gets "да")
      (cond (= @inner-counter 0)
            (do
              (println (format "\n%s\n", @hintFirst))
              (swap! inner-counter inc))
            (= @inner-counter 1)
            (do
              (println (format "\n%s\n", @hintSecond))
              (swap! inner-counter inc))
            (= @inner-counter 2)
            (do
              (println (format "\n%s\n", @hintThird)) 
              (reset! inner-counter 0)))
            (= gets "нет")         
            (println)
            :default 
            (recur inner-counter))))
 
 
;;;ЦИКЛ ВЫХОДА
;;;*****************************************************************************************************
(defn ExitLoop [] 
  (print "Введите да или нет: ")
  (flush)
  (let [out (string/lower-case (read-line))]
    (cond (= out "да")  (do
                          (ChangeData nick navigator score flag flag-inside)
                          (println "До скорого")
                          (System/exit 0))
          (= out "нет") nil
          :default     (ExitLoop))))
 
 
;;;ОЧИСТКА ЭКРАНА
;;;*****************************************************************************************************
(defn ClearScreen []
  (flush)
  (println (str (char 27) "[2J"))
  (println (str (char 27) "[;H")))
 
 
;;;ПЕЧАТЬ ВОПРОСА НА ЭКРАН
;;;******************************************************************************************************
(defn AskQuestion [question] 
  (println (format "%S" @question)))
 
(defn AskQuestionEnter [question flag-inside] 
  (println (format "%S" @question))
  (cond
    (= 1 @flag-inside)
    (do
      (println "Вы до выходя взяли одну подсказку. Вот она.")
      (println  @hintFirst))
    (= 2 @flag-inside) 
    (do 
      (println "Вы до выхода взяли две подсказки. Вот они.")
      (println @hintFirst)
      (println @hintSecond))
    (= 3 @flag-inside)
    (do 
      (println "Вы до выхода взяли три подсказки. Вот они.")
      (println @hintFirst)
      (println @hintSecond)
      (println @hintThird))))
 
 
;;;ИГРА
;;;******************************************************************************************************
 
 
(defn RightAnswer []
    (println "Да, это" @answer"!")
    (reset! flag 0)
    (ChangeDataWhenAnswer nick navigator score flag flag-inside)
    (ReadFile "/home/user/donor.txt" (swap! navigator inc))
    (Thread/sleep 2000)
    (ClearScreen)
    (AskQuestion question))
 
(defn WrongAnswer []
  (swap! flag inc)
  (print "Подсказку?[да|нет]: ")
  (flush)             
  (let [getty (string/lower-case (read-line))]
    (cond
        (= getty "да") 
        (do 
          (swap! flag-inside inc)
          (cond
            (= @flag-inside 1)                  
            (println  @hintFirst)
            (= @flag-inside 2)
            (println  @hintSecond)
            (= @flag-inside 3)
            (do 
              (println @hintThird)          
              (reset!  flag-inside 0))))
        (= getty "нет")
        (do
          (print "Ваш ответ: ")
          (flush)
          (let [inner-getty (string/lower-case (read-line))]
            (if (not= inner-getty @answer)
                (do
                  (println "Неверно")
                  (reset! flag 0)
                  (ReadFile "/home/user/donor.txt" (swap! navigator inc))
                  (Thread/sleep 2000)
                  (ClearScreen)
                  (AskQuestion question))     
                (RightAnswer))))
      :else
      (HintLoop flag-inside))))
 
          
 
(defn QueryExit []
  (print "Выйти [Да|Нет]: ")
  (flush)
  (let [exit (string/lower-case (read-line))]
  (cond
    (= exit "нет")
    nil
    (= exit "да") 
    (do
      (ChangeData nick navigator score flag flag-inside)
      (println "До скорого")
      (System/exit 0))
    :default
    (ExitLoop))))
 
 
 
(defn Game []
 (print "Ваш ответ: ")
 (flush) 
 (let [gets (string/lower-case (read-line))]
   (cond 
       (> @flag 2)
       (do
       (println "Нет, это не " gets)  
       (reset! flag 0)
       (ReadFile "/home/user/donor.txt" (swap! navigator inc))
       (Thread/sleep 2000)
       (ClearScreen)
       (AskQuestion question)
       (Game))        
       (> (count gets) (+ (count @answer) 20))  
       (println "Слишком много букв!\n")   
       (= gets  "меню")
       (do
         (ChangeData nick navigator score flag flag-inside) 
         "EXIT")        
       (= gets "выход")
       (QueryExit)
       (= gets "стат")
       (do
        (PersonalStat)
        (Game)) 
       (not= gets (string/lower-case @answer))
       (do
         (println "Нет, это не" gets)
         (WrongAnswer)
         (Game))
       (= gets (string/lower-case @answer))
       (do
         (RightAnswer)
         (Game))
       :default nil)))       
     
;;;******************************************************************************************************
 
 
;;;МЕНЮ
;;;******************************************************************************************************
(defn Launcher [] 
  (println "1)Регистрация")
  (println "2)Вход")
  (println "3)Статистика")
  (println "4)Выход")
  (let [get-launcher (read-line)]
    (cond
          (= get-launcher "4") (println "До встречи")
          (= get-launcher "1") (if (not= "EXIT" (RegPlayer)) 
                               (do
                                 (ReadFile "/home/user/donor.txt" @navigator)
                                 (Thread/sleep 3000)
                                 (ClearScreen)
                                 (AskQuestion question)
                                 (when (= "EXIT" (Game)) 
                                   (ClearScreen)
                                   (PrintLogo)
                                   (recur)))
                               (do 
                                 (ClearScreen)
                                 (PrintLogo)
                                 (recur)))
          
          (= get-launcher "2") (if (not= "EXIT" (TestEnter)) 
                               (do 
                                 (ReadFile "/home/user/donor.txt" @navigator)
                                 (Thread/sleep 3000)
                                 (ClearScreen)
                                 (AskQuestionEnter question flag-inside)
                                 (when (= "EXIT" (Game))
                                   (ClearScreen)
                                   (PrintLogo)
                                   (recur)))
                              (do 
                                (ClearScreen)
                                (PrintLogo)
                                (recur)))
          
         
         (= get-launcher "3")  (do
                                 (GetStatFromLauncher players)
                                 (ClearScreen)
                                 (PrintLogo)
                                 (recur))
         
         
          :default (do 
                     (ClearScreen)
                     (PrintLogo)
                     (recur)))))
 
                                                      
;;;ЗАПУСК
;;;******************************************************************************************************
(ClearScreen)
(PrintLogo)
(Launcher)

(defun dw-main (expression)
   (let ((w (gensym 'w)))
      (grwCreate w 600 400 (output expression) _WHITE)
      (grwSetParm w 3 0 _WHITE)
      (grwFont w "Tahoma" 12 T Nil)
      (grwScale w -120 120 -120 120)
      (draw-expr expression w -90 80)
      (grwShow w)))
 
(defun arrow (w x1 y1 x2 y2)
  (if (<= (abs (- y1 y2)) 1.0e-8)
      (progn 
          (grwline w x1 y1 x2 y2 _RED)
          (grwline w x2 y2 (- x2 3) (+ y2 3) _RED)           
          (grwline w x2 y2 (- x2 3) (- y2 3) _RED))
      (progn 
          (grwline w x1 y1 x2 y2 _RED)
          (grwline w x2 y2 (- x2 3) (+ y2 3) _RED)           
          (grwline w x2 y2 (+ x2 3) (+ y2 3) _RED))))           
 
(defun draw-expr(e w x y)
  (cond ((atom e)
         (grwRect w (- x 10) (- y 20) (+ x 10) y _BLACK)
         (if e (grwPrint w x (- y 5) (output e) _BLACK)
               (progn (grwLine w (- x 10) (- y 20) (+ x 10) y _BLACK)
                      (grwLine w (- x 10) y (+ x 10) (- y 20) _BLACK))))
        ((listp (car e))
               (grwRect w (- x 10) (- y 20) (+ x 10) y _BLACK)
               (grwRect w (+ x 10) (- y 20) (+ x 30) y _BLACK)
               (arrow w x (- y 10) x (- y 38))
               (if (cdr e) (progn 
                                 (draw-expr (cdr e) w (+ x 50) y)
                                 (arrow w (+ x 20) (- y 10) (+ x 40) (- y 10)))
                          (progn (grwLine w (+ x 10) (- y 20) (+ x 30) y _BLACK)
                                 (grwLine w (+ x 10) y (+ x 30) (- y 20) _BLACK)))                          
               (draw-expr (car e) w x (- y 40)))
        (t (draw-expr (car e) w x y)
           (grwRect w (+ x 10) (- y 20) (+ x 30) y _BLACK)
           (if (cdr e) (progn (draw-expr (cdr e) w (+ x 50) y)
                              (arrow w (+ x 20) (- y 10) (+ x 40) (- y 10)))
                       (progn (grwLine w (+ x 10) (- y 20) (+ x 30) y _BLACK)
                              (grwLine w (+ x 10) y (+ x 30) (- y 20) _BLACK))))))
                              
(dw-main '(a (b c) d))
(dw-main '(a (b (c (d)))))