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

(setq *i* '((r a) (r b) (r c) (a 1) (a 2) (b 1) (b 2) (c 1) (c 2)))
(setq *g* '((A B) (A C) (B D) (D E) (E F) (E A) (E B)))
(setq *h* '((a b) (a c) (b c) (b d) (c e) (d e) (e f) (e g) (e h) (g h)))
 
(setq *ww* 250 *hh* 250)
 
(defun get-vert (v g p)
 (iter (for pair in g)
   (when (and (eq v (car pair)) (not (member (cadr pair) p))) (return (cadr pair)))
   (when (and (eq v (cadr pair)) (not (member (car pair) p))) (return (car pair)))))
 
(defun get-lvert (v g p)
  (let ((r nil))
        (iter (for pair in g)
          (when (and (eq v (car pair)) (not (member (cadr pair) p))) (collecting (cadr pair) into r))
          (when (and (eq v (cadr pair)) (not (member (car pair) p))) (collecting (car pair) into r))) r))
 
(defun dfs! (g pth stk)
  (cond ((null stk) pth)
        (t (let ((h (get-vert (car stk) g pth)))
                 (if (null h) (dfs! g pth (cdr stk))
                              (dfs! g (cons h pth) (cons h stk)))))))
(defun dfs (start g)
  (dfs! g (list start) (list start)))
 
(defun bfs! (g pth que)
  (cond ((null que) pth)
        (t (let ((h (get-lvert (car que) g pth)))
                 (if (null h) (bfs! g pth (cdr que))
                              (bfs! g (append pth h) (append (cdr que) h)))))))
(defun bfs (start g)
  (bfs! g (list start) (list start)))
 
(defun a2s (x)
 (strUcase (implode (cons '&DQ (append (explode x) (list '&DQ))))))  
  
(defun get-num (a vs)
  (iter (for i upfrom 0) (for x in vs) (when (eq x a) (return i))))  
  
(defun draw-graph (g)
  (let* ((w (gensym 'w))
         (vs (setof (apply 'append g)))
         (n  (length vs))
         (coords nil)   
         (fi (/ (* 2 _pi) n)))
    (iter (for i from 1 to n) (collecting (list (* 150 (cos (* (- i 1) fi))) (* 150 (sin (* (- i 1) fi)))) into coords))
    (grwCreate w *ww* *hh* "" _WHITE)
    (grwScale w -200 200 -200 200)
    (grwShow w)
    (iter (for pair in coords) (grwCircle w (car pair) (cadr pair) 10 _RED) (grwFill w (car pair) (cadr pair) _RED _RED))
    (iter (for pair in g) 
          (let* ((n1 (get-num (car pair) vs))
                 (n2 (get-num (cadr pair) vs))
                 (x1 (car (nth n1 coords)))
                 (y1 (cadr (nth n1 coords)))
                 (x2 (car (nth n2 coords)))
                 (y2 (cadr (nth n2 coords))))
            (grwLine w x1 y1 x2 y2 _RED)))       
    (iter (for i from 1 to n) (for a in vs) (grwPrint w (* 180 (cos (* (- i 1) fi))) (* 180 (sin (* (- i 1) fi))) (a2s a) _RED))))
        
 
(defun dfs!! (g pth stk w coords vs)
  (cond ((null stk) pth)
        (t (let ((h (get-vert (car stk) g pth)))
                 (if (null h) (dfs!! g pth (cdr stk) w coords vs)
                              (progn 
                                 (let* ((n1 (get-num h vs))
                                        (n2 (get-num (car stk) vs))
                                        (x1 (car (nth n1 coords)))
                                        (y1 (cadr (nth n1 coords)))
                                        (x2 (car (nth n2 coords)))
                                        (y2 (cadr (nth n2 coords))))                
                                    (grwCircle w x1 y1 10 _BLUE)
                                    (grwFill w x1 y1 _BLUE _BLUE)
                                    (grwCircle w x2 y2 10 _BLUE)
                                    (grwFill w x2 y2 _BLUE _BLUE)
                                    (grwLine w x1 y1 x2 y2 _BLUE)
                                    (sleep* 500)                                    
                                    (dfs!! g (cons h pth) (cons h stk)w coords vs))))))))
 
(defun draw-dfs (g)
  (let* ((w (gensym 'w))
         (vs (setof (apply 'append g)))
         (n  (length vs))
         (coords nil)   
         (fi (/ (* 2 _pi) n)))
    (iter (for i from 1 to n) (collecting (list (* 150 (cos (* (- i 1) fi))) (* 150 (sin (* (- i 1) fi)))) into coords))
    (grwCreate w *ww* *hh* "DFS" _WHITE)
    (grwSetParm  w 2 1 _RED _RED)
    (grwScale w -200 200 -200 200)
    (grwShow w)
    (iter (for pair in coords) (grwCircle w (car pair) (cadr pair) 10 _RED) (grwFill w (car pair) (cadr pair) _RED _RED))
    (iter (for pair in g) 
          (let* ((n1 (get-num (car pair) vs))
                 (n2 (get-num (cadr pair) vs))
                 (x1 (car (nth n1 coords)))
                 (y1 (cadr (nth n1 coords)))
                 (x2 (car (nth n2 coords)))
                 (y2 (cadr (nth n2 coords))))
            (grwLine w x1 y1 x2 y2 _RED)))       
    (iter (for i from 1 to n) (for a in vs) (grwPrint w (* 180 (cos (* (- i 1) fi))) (* 180 (sin (* (- i 1) fi))) (a2s a) _RED))
     (dfs!! g (list (car vs)) (list (car vs)) w coords vs)
     ;;(say "OK!")
      ))
 
 
(defun bfs!! (g pth que w coords vs)
  (cond ((null que) pth)
        (t (let ((h (get-lvert (car que) g pth)))
                 (if (null h) (bfs!! g pth (cdr que) w coords vs)
                              (progn 
                                  (let* ((n1 (get-num (car que) vs))
                                         (x1 (car (nth n1 coords)))
                                         (y1 (cadr (nth n1 coords))))
                                       (iter (for pp in h) 
                                             (let* ((n2 (get-num pp vs))
                                                    (x2 (car (nth n2 coords)))
                                                    (y2 (cadr (nth n2 coords)))) 
                                                  (grwCircle w x1 y1 10 _BLUE)
                                                  (grwFill w x1 y1 _BLUE  _BLUE)
                                                  (grwCircle w x2 y2 10 _BLUE)
                                                  (grwFill w x2 y2 _BLUE _BLUE)
                                                  (grwLine w x1 y1 x2 y2 _BLUE)
                                                  (sleep* 500)))                                    
                                       (bfs!! g (append pth h) (append (cdr que) h) w coords vs))))))))  
                            
(defun draw-bfs (g)
  (let* ((w (gensym 'w))
         (vs (setof (apply 'append g)))
         (n  (length vs))
         (coords nil)   
         (fi (/ (* 2 _pi) n)))
    (iter (for i from 1 to n) (collecting (list (* 150 (cos (* (- i 1) fi))) (* 150 (sin (* (- i 1) fi)))) into coords))
    (grwCreate w *ww* *hh* "BFS" _WHITE)
    (grwSetParm  w 2 1 _RED _RED)
    (grwScale w -200 200 -200 200)
    (grwShow w)
    (iter (for pair in coords) (grwCircle w (car pair) (cadr pair) 10 _RED) (grwFill w (car pair) (cadr pair) _RED _RED))
    (iter (for pair in g) 
          (let* ((n1 (get-num (car pair) vs))
                 (n2 (get-num (cadr pair) vs))
                 (x1 (car (nth n1 coords)))
                 (y1 (cadr (nth n1 coords)))
                 (x2 (car (nth n2 coords)))
                 (y2 (cadr (nth n2 coords))))
            (grwLine w x1 y1 x2 y2 _RED)))       
    (iter (for i from 1 to n) (for a in vs) (grwPrint w (* 180 (cos (* (- i 1) fi))) (* 180 (sin (* (- i 1) fi))) (a2s a) _RED))
     (bfs!! g (list (car vs)) (list (car vs)) w coords vs)
     ;;(say "OK!")
      ))                            
     
(draw-dfs *h*)
 
(grwShowall -1)
 
(draw-bfs *h*)
 
(grwShowall -1)
 
(draw-dfs *i*)
 
(grwShowall -1)
 
(draw-bfs *i*)
 
(grwShowall -1)
 
(draw-dfs *g*)
 
(grwShowall -1)
 
(draw-bfs *g*)
 
(grwShowall -1)

(defun draw-tree (n fi)
  (let ((w (gensym 'w))
        (xy (rot-list (draw-t 0 100 40 20 n) fi)))
    (grwCreate w 300 300 "Binary tree" _WHITE)
    (grwScale w -100 100 -100 100)
    
     (grwSetParm  w 2 1 _RED _WHITE)
 
    (grwShow w)
    (mapcar (lambda (pair) (grwLine w (nth 0 pair) (nth 1 pair) (nth 2 pair) (nth 3 pair) _RED)) xy)
    'OK))
 
(defun draw-t (x y dx dy n &optional (r nil))
  (cond ((zerop n) r)
        (t (let ((ll (draw-t (+ x dx) (- y dy) (* dx 0.45) (* dy 1.1) (- n 1) r))
                 (rr (draw-t (- x dx) (- y dy) (* dx 0.45) (* dy 1.1) (- n 1) r)))
               (append ll rr (list (list x y (+ x dx) (- y dy)) (list x y (- x dx) (- y dy)))))))) 
    
(defun rot (x y f)
  (let* ((fi (* _pi (/ f 180.0)))
         (cosfi (cos fi))
         (sinfi (sin fi))
         (x1 (+ (* cosfi x) (* sinfi y)))
         (y1 (- (* cosfi y) (* sinfi x))))
    (list x1 y1)))
 
(defun rot-list (lst fi)
  (mapcar (lambda (p)
    (let ((x1 (nth 0 p))
          (y1 (nth 1 p))
          (x2 (nth 2 p))
          (y2 (nth 3 p)))
     (append (rot x1 y1 fi) (rot x2 y2 fi)))) lst))
 
(draw-tree (str2fix (ask "Число уровней")) (str2flo (ask "Угол поворота в градусах")))

(defun start (&optional (lv 3))
  (let ((w (gensym 'w)))
    (grwCreate w 500 500 "Треугольник Серпинского" _WHITE)
    (grwShow w)
    (grwScale w -100 100 -100 100)
    (grwSetParm w 3 1 _WHITE)
    (triangle w (list -90 -90 0 90 90 -90) lv)))
    
    
(defun triangle (w coord &optional (lv 3))
   (when (plusp lv)
     (let ((x1 (nth 0 coord))
           (y1 (nth 1 coord))
           (x2 (nth 2 coord))
           (y2 (nth 3 coord))
           (x3 (nth 4 coord))
           (y3 (nth 5 coord)))
       (grwLine w x1 y1 x2 y2 _RED)
       (grwLine w x1 y1 x3 y3 _RED)
       (grwLine w x2 y2 x3 y3 _RED)
       (grwFill w (/ (+ x1 x2 x3) 3.0) (/ (+ y1 y2 y3) 3.0) _RED _RED)
       (let ((xx1 (* 0.5 (+ x1 x2)))
             (yy1 (* 0.5 (+ y1 y2)))
             (xx2 (* 0.5 (+ x2 x3)))
             (yy2 (* 0.5 (+ y2 y3)))
             (xx3 (* 0.5 (+ x1 x3)))
             (yy3 (* 0.5 (+ y1 y3))))  
            (grwLine w xx1 yy1 xx2 yy2 _WHITE)
            (grwLine w xx1 yy1 xx3 yy3 _WHITE)
            (grwLine w xx2 yy2 xx3 yy3 _WHITE)
            (grwFill w (/ (+ xx1 xx2 xx3) 3.0) (/ (+ yy1 yy2 yy3) 3.0) _WHITE _WHITE)
            (triangle w (list x1 y1 xx1 yy1 xx3 yy3) (- lv 1))
            (triangle w (list xx1 yy1 x2 y2 xx2 yy2) (- lv 1))
            (triangle w (list xx3 yy3 xx2 yy2 x3 y3) (- lv 1))))))

#lang racket
 
(require racket/serialize)
(require racket/date)
 
(define database (void))
(define password (void))
(define name     (void))
(define created-user (void))
 
(serializable-struct user (login                ;Структура описывающая нашего пользователя.
                           password                     ;У вас она дожна быть своя: со своими вводными.
                           reg-time    
                           block-time  
                           last-visit  
                           tests       
                           zero-exam  
                           tre-exam    
                           random-exam) #:mutable)
 
(define dir-path (string-append (path->string (find-system-path 'home-dir)) ".mtable")) ;Определяем пути к папке
(define database-path  (string-append dir-path "/.database"))  ;И файлу с базой данных наших зарегистрированных пользователей.
 
;Функция для скрытого чтения пароля из терминала.
(define (read-pswd)
  (system "stty -echo")
  (begin0 (read-line (current-input-port))
    (system "stty echo")
    (newline))) 
 
:Превращаем текущую дату в строку.
(define (date-to-string date)
  (let* ((day    (number->string (date-day date)))
         (month  (number->string (date-month date)))
         (year   (number->string (date-year date)))
         (hour   (number->string (date-hour date)))
         (minute (number->string (date-minute date)))
         (second (number->string (date-second date))))
    (string-append day "/" month "/" year "/" hour ":" minute ":" second)))
 
;Читаем из пути(базы данных).
(define (read-from-path path)
                (call-with-input-file path
                   (λ (input) (read input))))
 
;Пишем в базу данных.
(define (write-data-to-file path)
                    (call-with-output-file database-path
                      (λ (output)
                                (write   (serialize database) output))
                      #:exists 'replace))
 
;Функция проверяет существует ли путь к базе данных:
;Если папка отсутствует, то создает папку. То же  самое с файлом.
;Если существует, но пуст, то пишет туда хеш-таблицу куда мы будем складывать наши данные о пользователях.
;Таким образом программа будет работать даже если пользователь случайно удалить файл или папку с данными.
 
(define (check-path-and-set!)
  (if (directory-exists? dir-path)
      (if (file-exists? database-path)
          (if (serializable? (read-from-path database-path))
          (set! database
               (call-with-input-file database-path
                 (λ (input) (deserialize (read input)))))
          (begin
            (call-with-output-file database-path
                  (λ (output) (write (serialize (make-hash)) output)) #:exists 'replace)
            (check-path-and-set!)))
          (begin
            (display-to-file (serialize (make-hash)) database-path)
            (check-path-and-set!)))
      (begin
        (make-directory dir-path)
        (check-path-and-set!))))
 
;Проверка наличия в строке цифр и букв.
(define (letter+num pswd)
  (if (empty? (regexp-match* #px"\\d+[a-z, A-Z | a-я, А-Я]|[a-z, A-Z | а-я, А-Я]+\\d" pswd))
      empty
      (list 'not-empty)))
 
;Проверяем пароль, который придумал пользователь, чтобы не был слабым и тд.
(define (test-password)
  (printf "Придумайте пароль: ")
  (flush-output)
  (let ((pswd (read-line (current-input-port))))
    (cond
      ((equal? pswd "б")
       "base")
      ((< (string-length pswd) 6)
       (begin
         (printf "Пароль должен быть не короче 7 символов,
а так же состоять из букв и цифр.\n")
         (test-password)))
       ((empty? (letter+num pswd))
        (begin
         (printf "Пароль должен быть не короче 7 символов,
а так же состоять из букв и цифр.\n")
         (test-password)))
       ((regexp-match #rx" " pswd)
        (begin
          (printf "Пароль не должен содержать пробелов и табуляции\n")
          (test-password)))
       ((regexp-match #rx"\t" pswd)
        (begin
          (printf "Пароль не должен содержать пробелов и табуляции\n")
          (test-password)))
        ((< (length (regexp-match* #px"\\d" pswd)) 3)
         (begin
           (printf "Слабый пароль. Придумайте получше.
Колличество цифр в пароле должно быть не меньше трех.\n")                   
           (test-password)))
        ((equal? (regexp-match #px"\\d\\d\\d" pswd) (list "123"))
         (begin
           (printf "Слабый пароль: содержит ряд чисел 123.\n")
           (test-password)))
        ((set! password pswd)))))
 
;Проверяем логин.
(define (test-login)
  (printf "Придумайте логин: ")
  (flush-output)
  (let ((login (read-line (current-input-port))))
    (cond
      ((equal? login "б") "base")
      ((not (equal? "free" (hash-ref database login "free")))
       (begin
         (printf "Это имя уже занято. Придумайте другое\n")
         (test-login)))
      ((not (regexp-match #rx"[a-z, A-Z | а-я, А-Я]" login))
       (begin
         (printf "Имя должно соcтоять из букв\n")
         (test-login)))
       ((regexp-match #rx" " login)
        (begin
          (printf "Имя не должено содержать пробелов и табуляции\n")
          (test-login)))
       ((regexp-match #rx"\t" login)
        (begin
          (printf "Имя не должен содержать пробелов и табуляции\n")
          (test-login)))
       ((< (string-length login) 3)
        (begin
          (printf "Имя не должно быть короче трех букв\n")
          (test-login)))
        ((set! name login)))))
 
;Cоздаем пользователя на текущий сеанс: заполняем из хеш-таблицы поля структуры.
(define (create-user)
  (set! created-user (user name password (date-to-string (current-date)) 0 (date-to-string (current-date)) empty (vector #f 0) (vector #f 0) (vector #f 0)))
  (hash-set! database name created-user))
 
:Регистрация пользователя.
(define (registration)
  (printf "Для возврата в меню: б\n")
  (if (equal? "base" (test-login))
      "base"
      (if (equal? "base" (test-password))
          "base"
          (begin
              (create-user)
              (write-data-to-file database-path)
              (set! created-user (void))
              (printf "Вы удачно зарегестрированы, ~a.\n" name)))))
 
;Проверяем логин, при авторизации.
(define (verify-login)
  (printf "Логин: ")
  (flush-output)
  (let ((login (read-line (current-input-port))))
    (cond
      ((equal? "б" login) "base")
      ((equal? "free" (hash-ref database login "free"))
       (begin
         (printf "Неверный логин.\n")
         (verify-login)))
       ((begin
          (set! name login)
          (void)))))) 
 
;Проверяем логин при входе в программу, когда пользователь уже зарегистрировался.
;После пяти неудачных попыток ввести пароль предлагается подождать 5 мин и вспомнить пароль. Дальнейшие попытки авторизации блокируются на 5 мин.
(define (verify-password [acc 0])
  (printf "Пароль: ")
  (flush-output)
  (let ((block-time (user-block-time (hash-ref database name)))
        (password (read-pswd)))
    (cond
      ((equal? "б" password) "base")
      ((and (not (equal? block-time 0))
            (< (- (current-seconds) block-time) 300))
       (begin
         (printf "Пропробуйте снова через ~a мин.\n" (if (< (/ (- 300 (- (current-seconds) block-time)) 60) 1)
                                                         1
                                                         (round (/ (- 300 (- (current-seconds) block-time)) 60))))
         (verify-password acc)))
      ((eq? acc 5)
       (begin
         (set-user-block-time!  (hash-ref database name) (current-seconds))
         (printf "Попытайтесь вспомнить пароль и попробоват позже.\n")
         (sleep 3)
         "base"))
          ((equal? password (user-password (hash-ref database name)))
           (begin
             (set-user-block-time! (hash-ref database name) 0)
             (void)))
          ((begin
             (printf "Неверный пароль.\n")
             (verify-password (add1 acc)))))))
 
;Авторизация для меню.
;Нужно переиминовать функцию в авторизацию или как-то так.
(define (login)
  (printf "Для возврата в меню: б\n")
  (if (equal? "base" (verify-login))
      "base"
      (if (equal? "base" (verify-password))
          "base"
          (begin
            (printf "Рады тебя видеть, ~a.\n" name) ;Потом удалить эту строку. И в других местах тоже, если есть
            (set-user-last-visit! (hash-ref database name) (date-to-string (current-date)))
            (set! password (void))
            (void)))))
 
;Вызываем соответсвующие функции для проверки.
(check-path-and-set!)
(registration)
(login)