/[gtk-cffi]/gtk-cffi/examples/calc-cffi.lisp
ViewVC logotype

Contents of /gtk-cffi/examples/calc-cffi.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Mon Apr 25 19:16:08 2011 UTC (2 years, 11 months ago) by rklochkov
Branch: slavsoft, MAIN
CVS Tags: initial, HEAD
Changes since 1.1: +0 -0 lines

Initial release
1 (asdf:oos 'asdf:load-op :gtk-cffi)
2
3 (defpackage :calculator
4 (:use #:common-lisp #:gtk-cffi #:gdk-cffi)
5 (:export #:run))
6
7 (in-package :calculator)
8
9 (defparameter *display* "0")
10
11 (defun find-number (str)
12 (cond
13 ((eql (length str) 0) "")
14 ((string= str "0") "")
15 ((digit-char-p (elt str 0)) (princ-to-string (read-from-string str)))
16 (t (find-number (subseq str 1)))))
17
18
19 (defun do-all (oper)
20 ;; (let ((op (operations calculator)))
21 ;; (setf (operations calculator) "test2 ok")
22 ;; op))
23 (setf *display*
24 (cond
25 ((numberp oper) (format nil "~a~a"
26 (find-number *display*)
27 oper))
28 (t "0")))
29 (update-display))
30
31 (defun build-buttons (table)
32 (mapcar
33 (lambda (row)
34 (mapcar
35 (lambda (elem)
36 (when elem
37 (make-instance 'button
38 :label (princ-to-string elem)
39 :signals
40 (list :clicked
41 (lambda (&rest rest)
42 (declare (ignore rest))
43 (do-all elem))))))
44 row)) table))
45
46 (defun to-right (str &optional (len 20))
47 (if (>= (length str) len)
48 str
49 (concatenate 'string
50 (make-string
51 (- len (length str)) :initial-element #\ ) str)))
52
53 (gtk-init)
54
55 (defparameter *calculator*
56 (gtk-model
57 'window :title "GTK test"
58 :signals (list :key-press-event
59 (lambda (widget event)
60 ; (declare (ignore widget ))
61 (do-all (parse-key (get-slot event :keyval)))
62 (format t "~a ~a~%" widget event))
63 :destroy :gtk-main-quit)
64 ('table
65 :kids (append
66 (list (list 4 (make-instance 'label :text "Калькулятор")))
67 (list (list 4 (make-instance 'label :id :display)))
68 (build-buttons
69 '((7 8 9 +)
70 (4 5 6 -)
71 (1 2 3 *)
72 (0 nil = /)))))))
73
74 (defun to-display (str)
75 (with-markup
76 (:background :cyan)
77 (to-right str)))
78
79 (defun update-display ()
80 (setf (text (object-by-id :display) :markup t) (to-display *display*)))
81
82 (defun parse-key (key)
83 (cond
84 ((<= 65456 key 65465) (- key 65456)) ; numpad number
85 ((<= 48 key 57) (- key 48)) ; top row number
86 (t key)))
87
88
89 (show *calculator*)
90 (gtk-main)
91
92
93

  ViewVC Help
Powered by ViewVC 1.1.5