Author: yamakenz
Date: Sat May 10 06:34:05 2008
New Revision: 5483
Modified:
trunk/scm/event.scm
trunk/scm/ng-action.scm
trunk/scm/ng-key.scm
Log:
* scm/ng-action.scm
- (actionset-fetch-action):
* Fix missing argument of a procedure call
* Simplify with and-let*
- (action-status, actionset-handle-event): Simplify with and-let*
* scm/event.scm
- (define-event):
* Simplify argument processing
* Replace cadr with meaningful record-field-spec-default-value
- (key-event-print-inspected): Replace deprecated procedure
* scm/ng-key.scm
- (mod_None, mod_Shift_L, mod_Shift_R, mod_Shift,
mod_Control_L, mod_Control_R, mod_Control, mod_Alt_L,
mod_Alt_R, mod_Alt, mod_Meta_L, mod_Meta_R, mod_Meta,
mod_Super_L, mod_Super_R, mod_Super, mod_Hyper_L,
mod_Hyper_R, mod_Hyper, mod_Caps_Lock, mod_ignore_Shift,
mod_ignore_Control, mod_ignore_Alt, mod_ignore_Meta,
mod_ignore_Super, mod_ignore_Hyper): Simplify with hex literal
Modified: trunk/scm/event.scm
==============================================================================
--- trunk/scm/event.scm (original)
+++ trunk/scm/event.scm Sat May 10 06:34:05 2008
@@ -34,6 +34,8 @@
;; component organization such as nested composer (input method) based
;; on loose relationships. -- YamaKen 2005-02-18
+(require-extension (sscm-ext))
+
(require "util.scm")
;;(require "utext.scm")
(require "ng-key.scm")
@@ -78,23 +80,20 @@
;; define-record
;; TODO: write test
(define define-event
- (lambda args
- (let* ((name (car args))
- (base-spec (alist-replace (list 'type name)
- (cadr args)))
- (ext-spec (if (null? (cddr args))
- '()
- (car (cddr args))))
- (base-defaults (map cadr base-spec))
- (ext-defaults (map cadr ext-spec))
- (creator (lambda args
- (append base-defaults
- args
- (list-tail ext-defaults (length args))))))
- (define-record (symbolconc name %HYPHEN-SYM 'event) (append
base-spec ext-spec))
- (eval (list 'define (symbolconc name %HYPHEN-SYM 'event-new) creator)
- (interaction-environment))
- (set! valid-event-types (cons name valid-event-types)))))
+ (lambda (name base-spec . rest)
+ (let-optionals* rest ((ext-spec ()))
+ (let* ((base-spec (alist-replace (list 'type name) base-spec))
+ (base-defaults (map record-field-spec-default-value base-spec))
+ (ext-defaults (map record-field-spec-default-value ext-spec))
+ (creator (lambda args
+ (append base-defaults
+ args
+ (list-tail ext-defaults (length args))))))
+ (define-record (symbol-append name %HYPHEN-SYM 'event)
+ (append base-spec ext-spec))
+ (eval (list 'define (symbol-append name %HYPHEN-SYM 'event-new) creator)
+ (interaction-environment))
+ (set! valid-event-types (cons name valid-event-types))))))
(define event-external-state
(lambda (ev state-id)
@@ -288,5 +287,5 @@
(define key-event-print-inspected
(lambda (msg ev)
(if inspect-key-event-translation?
- (puts (string-append msg
- (key-event-inspect ev))))))
+ (display (string-append msg
+ (key-event-inspect ev))))))
Modified: trunk/scm/ng-action.scm
==============================================================================
--- trunk/scm/ng-action.scm (original)
+++ trunk/scm/ng-action.scm Sat May 10 06:34:05 2008
@@ -33,6 +33,8 @@
;; - write test
;; - describe naming conventions and standard actions such as act_std_commit
+(require-extension (srfi 2))
+
(require "util.scm")
(require "i18n.scm")
(require "event.scm")
@@ -133,9 +135,8 @@
;; as appropriate different figure.
(define action-status
(lambda (act)
- (let ((proc (action-status-proc act)))
- (and proc
- (proc act)))))
+ (and-let* ((proc (action-status-proc act)))
+ (proc act))))
;; usage: (action-status-encoder-selected anthy-direct-mode?)
(define action-status-encoder-selected
@@ -178,19 +179,17 @@
(define actionset-fetch-action
(lambda (actset owner act-id)
- (let ((skeleton (actionset-fetch-action-skeleton actset)))
- (and skeleton
- (action-skeleton-bless skeleton owner)))))
+ (and-let* ((skeleton (actionset-fetch-action-skeleton actset act-id)))
+ (action-skeleton-bless skeleton owner))))
(define actionset-handle-event
(lambda (actset owner ev)
(and actset
(case (event-type ev)
((action)
- (let* ((act-id (action-event-action-id ev))
- (act (actionset-fetch-action actset owner act-id)))
- (and act
- (action-activate! act))))
+ (and-let* ((act-id (action-event-action-id ev))
+ (act (actionset-fetch-action actset owner act-id)))
+ (action-activate! act)))
(else
#f)))))
Modified: trunk/scm/ng-key.scm
==============================================================================
--- trunk/scm/ng-key.scm (original)
+++ trunk/scm/ng-key.scm Sat May 10 06:34:05 2008
@@ -70,38 +70,38 @@
mod_ignore_Super
mod_ignore_Hyper))
-(define mod_None 0)
-(define mod_Shift_L 1)
-(define mod_Shift_R 2)
-(define mod_Shift 4)
-(define mod_Control_L 8)
-(define mod_Control_R 16)
-(define mod_Control 32)
-(define mod_Alt_L 64)
-(define mod_Alt_R 128)
-(define mod_Alt 256)
-(define mod_Meta_L 512)
-(define mod_Meta_R 1024)
-(define mod_Meta 2048)
-(define mod_Super_L 4096)
-(define mod_Super_R 8192)
-(define mod_Super 16384)
-(define mod_Hyper_L 32768)
-(define mod_Hyper_R 65536)
-(define mod_Hyper 131072)
-(define mod_Caps_Lock 262144)
-;;(define 524288)
-;;(define 1048576)
-(define mod_ignore_Shift 2097152)
-(define mod_ignore_Control 4194304)
-(define mod_ignore_Alt 8388608)
-(define mod_ignore_Meta 16777216)
-(define mod_ignore_Super 33554432)
-(define mod_ignore_Hyper 67108864)
-;;(define 134217728) ;; incapable by storage-compact
-;;(define 268435456) ;; incapable by storage-compact
-;;(define 536870912) ;; incapable by storage-compact
-;;(define 1073741824) ;; incapable by storage-compact
+(define mod_None #x00000000)
+(define mod_Shift_L #x00000001)
+(define mod_Shift_R #x00000002)
+(define mod_Shift #x00000004)
+(define mod_Control_L #x00000008)
+(define mod_Control_R #x00000010)
+(define mod_Control #x00000020)
+(define mod_Alt_L #x00000040)
+(define mod_Alt_R #x00000080)
+(define mod_Alt #x00000100)
+(define mod_Meta_L #x00000200)
+(define mod_Meta_R #x00000400)
+(define mod_Meta #x00000800)
+(define mod_Super_L #x00001000)
+(define mod_Super_R #x00002000)
+(define mod_Super #x00004000)
+(define mod_Hyper_L #x00008000)
+(define mod_Hyper_R #x00010000)
+(define mod_Hyper #x00020000)
+(define mod_Caps_Lock #x00040000)
+;;(define #x00080000)
+;;(define #x00100000)
+(define mod_ignore_Shift #x00200000)
+(define mod_ignore_Control #x00400000)
+(define mod_ignore_Alt #x00800000)
+(define mod_ignore_Meta #x01000000)
+(define mod_ignore_Super #x02000000)
+(define mod_ignore_Hyper #x04000000)
+;;(define #x08000000) ;; incapable by storage-compact
+;;(define #x10000000) ;; incapable by storage-compact
+;;(define #x20000000) ;; incapable by storage-compact
+;;(define #x40000000) ;; incapable by storage-compact
(define modifier-shift-mask
(bitwise-ior mod_Shift_L mod_Shift_R mod_Shift))
