Тема: LISP. Калькулятор для работы со строками
Примечание:
1. Довольно образованная программуля - выполняет +,-,*,/. Умеет выбрасывать из строк буквы и многое другое.
2. Макрос для кнопки будет работать только если файл с когом программы уже подгружен.
(defun calc_strings (
/
rez
ans
str
entity
num
text_hight
old_color
old_error
old_colors_list
)
;;;инициализация
(setq old_error *error*)
(vl-load-com)
(setq old_colors_list '())
;;;переопределение обработчика ошибок
(defun *error* (msg)
;;; восстановление цветов
(foreach item old_colors_list
(vla-put-color (vlax-ename->vla-object (car item)) (cdr item))
)
(princ "\Aborted: ")
(princ msg)
(princ)
(setq *error* old_error)
(vl-exit-with-error "\nGood luck")
)
(if (= (setq rez (getreal "\nEnter an start result <0>:")) nil) (setq rez 0));Запрос начального значения
;по умолчанию 0
(while (setq ans (getstring "\nEnter an option (Adding, Subtraction, Multiplication, Division, Output):"));запрос опции
;; Проверка на соответствие типа
(if (or (= ans "a") (= ans "A") (= ans "ф") (= ans "Ф"));если введена опция а
(while (setq entity (entsel "\n(Adding)Select string:"));если выбрали строку
(if (setq str (cdr (assoc 1 (entget (car entity)))))
;если удалось получить Primary text value
(if (setq num (get_num str));если получилось извлечь число
(progn (setq old_color (vla-get-color (vlax-ename->vla-object (car entity))))
(setq rez (+ rez num))
(princ (strcat "\nCurrent result - " (rtos rez 2 8)))
(vla-put-color (vlax-ename->vla-object (car entity)) 1)
(if (not (assoc (car entity) old_colors_list))
(setq old_colors_list (cons (cons (car entity) old_color) old_colors_list))
)
);прибавить его к результату
(princ "\nWrong number format!");если не получилось извлечь - выдать сообщение
)
;если не удалось
(princ "\nThe selected object does not have a Primary text value")
)
); end while
);END ADDING
;; Проверка на соответствие типа
(if (or (= ans "s") (= ans "S") (= ans "ы") (= ans "Ы"));если введена опция а
(while (setq entity (entsel "\n(Substraction)Select string:"));если выбрали строку
(if (setq str (cdr (assoc 1 (entget (car entity)))))
;если удалось получить Primary text value
(if (setq num (get_num str));если получилось извлечь число
(progn (setq old_color (vla-get-color (vlax-ename->vla-object (car entity))))
(setq rez (- rez num))
(princ (strcat "\nCurrent result - " (rtos rez 2 8)))
(vla-put-color (vlax-ename->vla-object (car entity)) 1)
(if (not (assoc (car entity) old_colors_list))
(setq old_colors_list (cons (cons (car entity) old_color) old_colors_list))
)
);прибавить его к результату
(princ "\nWrong number format!");если не получилось извлечь - выдать сообщение
)
;если не удалось
(princ "\nThe selected object does not have a Primary text value")
)
); end while
);END SUBSTRACTION
;; Проверка на соответствие типа
(if (or (= ans "M") (= ans "m") (= ans "ь") (= ans "Ь"));если введена опция а
(while (setq entity (entsel "\n(Multiplication)Select string:"));если выбрали строку
(if (setq str (cdr (assoc 1 (entget (car entity)))))
;если удалось получить Primary text value
(if (setq num (get_num str));если получилось извлечь число
(progn (setq old_color (vla-get-color (vlax-ename->vla-object (car entity))))
(setq rez (* rez num))
(princ (strcat "\nCurrent result - " (rtos rez 2 8)))
(vla-put-color (vlax-ename->vla-object (car entity)) 1)
(if (not (assoc (car entity) old_colors_list))
(setq old_colors_list (cons (cons (car entity) old_color) old_colors_list))
)
);прибавить его к результату
(princ "\nWrong number format!");если не получилось извлечь - выдать сообщение
)
;если не удалось
(princ "\nThe selected object does not have a Primary text value")
)
); end while
);end MULTIPLICATION
;; Проверка на соответствие типа
(if (or (= ans "В") (= ans "в") (= ans "D") (= ans "d"));если введена опция а
(while (setq entity (entsel "\n(Division)Select string:"));если выбрали строку
(if (setq str (cdr (assoc 1 (entget (car entity)))))
;если удалось получить Primary text value
(if (setq num (get_num str));если получилось извлечь число
(progn (setq old_color (vla-get-color (vlax-ename->vla-object (car entity))))
(setq rez (/ rez num))
(princ (strcat "\nCurrent result - " (rtos rez 2 8)))
(vla-put-color (vlax-ename->vla-object (car entity)) 1)
(if (not (assoc (car entity) old_colors_list))
(setq old_colors_list (cons (cons (car entity) old_color) old_colors_list))
)
);прибавить его к результату
(princ "\nWrong number format!");если не получилось извлечь - выдать сообщение
)
;если не удалось
(princ "\nThe selected object does not have a Primary text value")
)
); end while
);end DIVISION
;; вывод результата на экран
(if (or (= ans "o") (= ans "O") (= ans "щ") (= ans "Щ"))
(progn
(vl-cmdf "_.UCS" "_w")
(create_text (rtos rez 2 8)
(getpoint "\nType insertion point:")
(if (setq text_hight (getint "\nEnter text hidht <8>:")) text_hight 8)
(vla-get-modelspace (vla-get-ActiveDocument (vlax-get-acad-object))))
);end progn
)
(if (= ans "");при вводе пустой строки
(progn
;;; восстановление цветов
(foreach item old_colors_list
(vla-put-color (vlax-ename->vla-object (car item)) (cdr item))
)
(princ (strcat "\nFinal result - " (rtos rez 2 8)));выдать конечный результат
(vl-exit-with-error "\nGood luck");выйти
)
)
);end while ANS
);end defun
(defun get_num (
str
/
ind
ascii_list
char_list
ret_str
)
(setq ind 1)
(setq ascii_list '())
(repeat (strlen str)
(setq ascii_list (cons (ascii (substr str ind 1)) ascii_list))
(setq ind (1+ ind))
)
(setq ascii_list (reverse ascii_list))
(setq ascii_list (vl-remove-if-not (function (lambda (x) (or
(= x 48)
(= x 49)
(= x 50)
(= x 51)
(= x 52)
(= x 53)
(= x 54)
(= x 55)
(= x 56)
(= x 57)
(= x 46)
(= x 44)
))) ascii_list))
(setq ascii_list (subst 46 44 ascii_list))
(foreach character ascii_list (setq char_list (cons (chr character) char_list)))
(setq char_list (reverse char_list))
(setq ret_str "")
(foreach item char_list (setq ret_str (strcat ret_str item)))
(distof ret_str)
)
(defun create_text (string ;; Строка, выводимая на экран
_insertion_point ;; координаты точки вставки
hight ;; высота текста
mspace_pointer ;; указатель на пространство модели
/
)
;;---------------------------------------------------------------------------------------
(vlax-invoke-method mspace_pointer
'AddMText ; название метода
(vlax-3d-point _insertion_point);преобразование
(* (strlen string) hight)
string
);end invoke method
(vlax-put-property (vlax-ename->vla-object (entlast)) "Height" hight)
)Макрос для кнопки
^C^C^P(calc_strings)
