CSV-Editor.lsp
（以下のスクリプトには、guisever 1.42 以上が必要です）
; CSV-Editor with gs:table
; 2010/10/ 8 first release.
; 2010/10/ 9 using flag of *tabList*.
; 2010/10/10 adding macro get-XXX for the current table information.
; 2010/10/12 adding adjustButton for adjusting the current table column and remove null-end-cell.
; 2010/10/13 adding File Menu.
; 2010/10/14 adding Edit Menu and functions of Edit.
; 2010/10/15 adding View Menu and functions for HTML.
; 2010/10/16 adding View Menu and functions for List.
; utility
(define *newlispDir* (env "NEWLISPDIR"))
(load (append *newlispDir* "/guiserver.lsp"))
(include "macro.lsp")
(include "newlisp-utility.lsp")
; define global variables
(define *tabList* '()) ; ((table filename (row column) flag)(...))
(define *currentCSV*)
(macro (get-tableID) (lookup *currentCSV* *tabList* 0))
(macro (get-filename) (lookup *currentCSV* *tabList* 1))
(macro (get-row/col) (lookup *currentCSV* *tabList* -2))
(macro (get-flag) (lookup *currentCSV* *tabList* -1))
(macro (get-index) ((ref *currentCSV* *tabList*) 0))
(define *currentRow* -1)
(define *currentCol* -1)
(define *rowBuffer*)
(define *colBuffer*)
(define *cellBuffer*)
(define *tabName*)
(define *Numerics* true)
(define *FontName* "Monospaced")
(define *FontSize* 8 )
(define *fileDir* (real-path))
(define *filemask* "csv CSV")
(define *description* "csv file")
(define *newTitle* "Untitled")
(define *newCount* -1)
; define the function for CSV (Comma-Separated Values)
(define CRLF "\x0d\x0a")
(define regexCRLF "\r*\n")
(defun stringEx (x)
(if (string? x) (string "\"" x "\"") (string x)))
(defun string-convert (str)
(if (catch (eval-string str) 'res) (if res res str) str))
(defun list2csv (lst)
(let (csv "")
(dolist (row lst)
(extend csv (join (map stringEx row) ",") CRLF))))
(defun list2csv|number (lst)
(let (csv "")
(dolist (row lst)
(extend csv (join (map (fn (x) (stringEx (string-convert x))) row) ",") CRLF))))
(defun csv2list (csv)
(let (lst '())
(dolist (row (parse (if (ends-with csv regexCRLF 0) (chop csv) csv) regexCRLF 0))
(push (map string-convert (parse row ",")) lst -1))
(setf (lst -1 -1) (if (string? $it) (trim $it "\r") $it))
lst))
(defun csvfile2list (file)
(cond ((directory? file) nil)
((file? file)
(csv2list (read-file file)))
(true nil)))
(defun delete-end-null-row (lsts)
(while (and lsts (for-all empty? (lsts -1)))
(pop lsts -1))
lsts)
(defun delete-end-null-all (lsts)
(aif (delete-end-null-row (transpose lsts))
(delete-end-null-row (transpose it))
'(())))
(defun insert-row (lst pos (item '()))
(let (len (length (lst 0)))
(push (apply append (dup (list item) len)) lst pos)))
(defun delete-row (lst (pos -1))
(if lst (pop lst pos))
lst)
; define the function for gs:table
(defun clear-table (table)
(gs:table-get-size table)
(dotimes (i (gs:table-size 0))
(dotimes (j (gs:table-size 1))
(gs:table-set-cell table i j ""))))
(defun make-table (file-name)
(let (csv (gensym))
(push (list csv file-name '(-1 -1) true) *tabList* -1)
(gs:table csv 'table-action (map string (sequence 1 5)))
(time (gs:table-add-row csv) 5)
;(gs:mouse-event edit-tab 'editarea-mouse-handler)
csv))
(defun set-table (lst table)
(let (len (length (lst 0)))
(gs:table-get-size table)
(when (< (gs:table-size 1) len)
(for (i (i+ (gs:table-size 1)) len) (gs:table-add-column table "")))
(dolist (row lst)
(let (r $idx)
(if (< r (gs:table-size 0))
(dolist (c row) (gs:table-set-cell table r $idx (string c)))
(gs:table-add-row table (map string row))))))
(unless (for-all (curry = "") (flat lst)) (adjust-column table)))
(defun adjust-column (table)
(gs:table-get-size table)
(gs:table-get table)
(dotimes (i (gs:table-size 1))
(let (lst (transpose gs:table-full))
(gs:table-set-column table i (* 100 (apply max (map length (lst i))))))))
; define the function for HTML
(define *header* [text]<!-- generated page -->
<html>
<table border="1">
[/text])
(define tableROW '("<tr>" "</tr>"))
(define tableDATA '("<td align=\"right\">" "</td>"))
(define tableHEADER '("<th>" "</th>"))
(define *footer* [text]</table>
</html>
[/text])
(defun addHTMLtag (data tag)
(string (tag 0) data (tag 1)))
(defun makeHTMLtable (lst)
(let (html *header*)
(dolist (row lst)
(if *Numerics* (setq row (map string-convert row)))
(extend html (tableROW 0))
(dolist (col row)
(extend html (addHTMLtag col (if (string? col) tableHEADER tableDATA))))
(extend html (tableROW 1) "\n"))
(extend html *footer*)))
; define handler
(define (HTML-save id op file)
(when file
(let (fname (base64-dec file))
(write-file fname (gs:get-text 'OutputArea)))))
(define (HTMLfile-action)
(let (tmp (if-not (directory? *tabName*) (parse *tabName* {\\|/} 0)))
(gs:save-file-dialog 'Frame 'HTML-save (join (chop tmp) "/")
(string ((parse (tmp -1) ".") 0) ".html")
"html HTML" "HTML file")))
(define (clip-action)
(gs:select-text 'OutputArea 0)
(gs:copy-text 'OutputArea))
(define (dialog-mouse-handler id type x y button cnt mods)
(if (or (= button 3) (= mods 18))
(gs:show-popup 'viewMenuPopup 'OutputArea x y)
))
(define (dialog-action id)
(gs:dialog 'Dialog 'Frame "HTML or List" FWidth FHeight nil true)
(gs:set-border-layout 'Dialog)
(gs:table-get *currentCSV*)
(cond ((ends-with id "HTML")
(gs:disable 'toolCopy)
(gs:enable 'toolHTMLFile)
(gs:text-pane 'OutputArea 'gs:no-action "text/html")
(gs:set-text 'OutputArea (makeHTMLtable gs:table-full)))
((ends-with id "List")
(gs:disable 'toolHTMLFile)
(gs:enable 'toolCopy)
(gs:text-pane 'OutputArea 'gs:no-action "text/plain")
(dolist (row gs:table-full)
(if (zero? $idx) (gs:set-text 'OutputArea "(")
(gs:append-text 'OutputArea " "))
(gs:append-text 'OutputArea (string (if *Numerics* (map string-convert row) row) "\n")))
(gs:append-text 'OutputArea ")"))
(true ))
(gs:add-to 'Dialog 'OutputArea "center")
(gs:mouse-event 'OutputArea 'dialog-mouse-handler)
(gs:set-visible 'Dialog true))
(define (openfile-action id op file)
(when file
(let (fname (if (= op "new") file (base64-dec file)))
(gs:set-text 'Status fname)
(let (lst (if (= op "new") '(()) (csvfile2list fname)))
(if lst
(begin
(let (table (aif (ref fname *tabList*) (*tabList* (it 0) 0) (make-table fname)))
(gs:insert-tab 'CSVtab table (lookup table *tabList* 1) (length *tabList*))
(gs:request-focus 'CSVtab (length *tabList*))
(set-table lst table)))
(gs:set-text 'Status (string fname " is not csv file.")))))))
(define (open-file-dialog)
(if *currentCSV* (setf (get-row/col) (list *currentRow* *currentCol*)))
(gs:open-file-dialog 'Frame 'openfile-action *fileDir* *filemask* *description*))
(define (savefile-action id op file)
(when (or (and (= op "save") file) (not op))
(gs:table-get *currentCSV*)
(let (fname (if file (base64-dec file) (get-filename))
lsts (delete-end-null-all gs:table-full))
(gs:set-text 'Status fname)
(write-file fname (if *Numerics*
(list2csv|number lsts)
(list2csv lsts)))
(when (= op "save")
(setf (get-filename) fname)
(gs:set-text 'CSVtab fname (get-index)))
(setf (get-flag) true))))
(define (save-file-dialog)
(let (tmp (if-not (directory? *tabName*) (parse *tabName* {\\|/} 0)))
(if tmp
(gs:save-file-dialog 'Frame 'savefile-action (join (chop tmp) "/") (tmp -1) *filemask* *description*)
(gs:save-file-dialog 'Frame 'savefile-action *fileDir* "" *filemask* *description*))))
(define (save-action)
(unless (get-flag)
(if (starts-with (get-filename) "Untitled") (save-file-dialog) (savefile-action))))
(define (clear-action)
(setf (get-flag) nil)
(clear-table *currentCSV*))
(define (table-action id row col data)
;(println "id=" id " row=" row " col=" col " data=" data)
(setf (get-flag) nil)
(setq *currentRow* row *currentCol* col)
(gs:set-text 'tableInfo (string "row:"row " column:" col " value=" data))
)
(define (tab-changed id tabID title tabPos)
;(println "id=" id " tabID=" tabID " title=" (base64-dec title) " tabPos=" tabPos)
(let (fname (base64-dec title))
(if *currentCSV* (setf (get-row/col) (list *currentRow* *currentCol*)))
(aif (ref fname *tabList*) (setq *currentCSV* (*tabList* (it 0) 0)))
(setq *currentRow* ((get-row/col) 0)
*currentCol* ((get-row/col) 1))
(gs:set-text 'Status fname)
(setq gs:table-cell "")
(if (and (> *currentRow* -1) (> *currentCol* -1)) (gs:table-get-cell *currentCSV* *currentRow* *currentCol*))
(gs:set-text 'tableInfo (string "row:"*currentRow* " column:" *currentCol* " value=" gs:table-cell))
(setq *tabName* fname)))
(define (check-action id selected)
(setf (get-flag) nil)
;(println "id:" id " checked:" selected)
(setq *Numerics* selected)
)
(define (new-action)
(++ *newCount*)
(let (fname (if (zero? *newCount*)
(string *newTitle* ".csv")
(string *newTitle* " (" *newCount* ").csv")))
(openfile-action "id" "new" fname)))
(define (key-action id type code modifiers)
;(println "id:" id " type:" type " key code:" code " modifiers:" modifiers)
)
(define (insert-action id)
(setf (get-flag) nil)
(gs:table-get *currentCSV*)
(if (ends-with id "Row")
(set-table (insert-row gs:table-full *currentRow* "") *currentCSV*)
(set-table (transpose (insert-row (transpose gs:table-full) *currentCol* "")) *currentCSV*)))
(define (delete-action id)
(setf (get-flag) nil)
(gs:table-get *currentCSV*)
(clear-table *currentCSV*)
(unless (apply empty? gs:table-full)
(if (ends-with id "Row")
(set-table (delete-row gs:table-full *currentRow*) *currentCSV*)
(set-table (transpose (delete-row (transpose gs:table-full) *currentCol*)) *currentCSV*))))
(macro (cut-row L P) (pop L P))
(define (cut-action id)
(setf (get-flag) nil)
(gs:table-get *currentCSV*)
(clear-table *currentCSV*)
(unless (apply empty? gs:table-full)
(cond ((and (ends-with id "Row") (> *currentRow* -1))
(setq *rowBuffer* (cut-row gs:table-full *currentRow*))
(gs:enable 'editPasteRow)
(set-table gs:table-full *currentCSV*))
((and (ends-with id "Col") (> *currentCol* -1))
(let (tmp (transpose gs:table-full))
(setq *colBuffer* (cut-row tmp *currentCol*))
(gs:enable 'editPasteCol)
(set-table (transpose tmp) *currentCSV*)))
(true ))))
(define (copy-action id)
(setf (get-flag) nil)
(gs:table-get *currentCSV*)
(unless (apply empty? gs:table-full)
(cond ((and (ends-with id "Row") (> *currentRow* -1))
(gs:enable 'editPasteRow)
(setq *rowBuffer* (gs:table-full *currentRow*)))
((and (ends-with id "Col") (> *currentCol* -1))
(gs:enable 'editPasteCol)
(setq *colBuffer* ((transpose gs:table-full) *currentCol*)))
(true ))))
(define (paste-action id)
(setf (get-flag) nil)
(gs:table-get *currentCSV*)
(clear-table *currentCSV*)
(cond ((and (ends-with id "Row") (> *currentRow* -1))
(setf (gs:table-full *currentRow*) *rowBuffer*)
(set-table gs:table-full *currentCSV*))
((and (ends-with id "Col") (> *currentCol* -1))
(gs:table-get-size *currentCSV*)
(letn (len (- (length *colBuffer*) (gs:table-size 0))
tmp (if (< len 1) gs:table-full
(append gs:table-full (dup (apply append (dup '("") (gs:table-size 1))) len))))
(setq tmp (transpose tmp))
(setf (tmp *currentCol*) (if (< len 1)
(append *colBuffer* (apply append (dup '("") (- len))))
*colBuffer*))
(set-table (transpose tmp) *currentCSV*)))
(true )))
(define (edit-action id)
(setf (get-flag) nil)
(gs:table-get *currentCSV*)
(cond ((ends-with id "Cut")
(gs:enable 'editPaste)
(setq *cellBuffer* "")
(swap (gs:table-full *currentRow* *currentCol*) *cellBuffer*)
(set-table gs:table-full *currentCSV*))
((ends-with id "Copy")
(gs:enable 'editPaste)
(setq *cellBuffer* (gs:table-full *currentRow* *currentCol*)))
((ends-with id "Paste")
(setf (gs:table-full *currentRow* *currentCol*) *cellBuffer*)
(set-table gs:table-full *currentCSV*))
(true ))
(set-table gs:table-full *currentCSV*))
(define (remove-csv id res)
(case res
;(0 ) ; yes
(1 ) ; no
(2 ) ; cancel
(true (let (tab (get-index)
table *currentCSV*)
(setq *currentCSV* nil)
(gs:remove-tab 'CSVtab tab)
(pop-assoc table *tabList*)))
))
(define (close-action id)
(if (< 1 (length *tabList*))
(if (get-flag)
(remove-csv)
(gs:confirm-dialog 'Frame
'remove-csv
"close CSV file"
(string "Abandon unsaved " (get-filename))
"yes-no"))
(closed-window)))
(define (quit-action id res)
(if (= res 0) (exit)))
(define (closed-window)
(if (dolist (lst *tabList* (nil? (lst -1))) nil)
(gs:confirm-dialog 'Frame
'quit-action
"Quit CSV Editor"
"Quit and lose unsaved content ?"
"yes-no")
(exit)))
(define (adjust-action)
(unless (get-flag)
(gs:table-get *currentCSV*)
(letn (idx (get-index)
fname (get-filename)
table (make-table fname))
(pop *tabList* -1)
(setf (get-tableID) table)
(gs:insert-tab 'CSVtab table fname idx)
(set-table (delete-end-null-all gs:table-full) table)
(gs:remove-tab 'CSVtab (i+ idx))
(gs:request-focus 'CSVtab idx)
)))
(define (resize-action id width height)
(setq FWidth width FHeight height))
; initialization
(gs:init)
(gs:get-version)
(setq FPosX 50 FPosY 50 FWidth 640 FHeight 480)
(gs:frame 'Frame FPosX FPosY FWidth FHeight "CSV Editor with gs:table")
(gs:tool-bar 'ButtonPanel)
;(gs:set-flow-layout 'ButtonPanel "left")
(gs:panel 'StatusPanel)
(gs:label 'Status (real-path))
(gs:label 'tableInfo "row:-1 column:-1 value=")
(gs:check-box 'Number 'check-action "Numerics prior" *Numerics*)
(gs:set-border-layout 'StatusPanel)
(gs:add-to 'StatusPanel 'Status "west" 'tableInfo "center" 'Number "east")
(gs:image-button 'newButton 'new-action "/local/new32.png" "/local/new-down32.png")
(gs:image-button 'fileButton 'open-file-dialog "/local/folder-opened32.png" "/local/folder-opened-down32.png")
(gs:image-button 'saveButton 'save-action "/local/save32.png" "/local/save-down32.png")
(gs:image-button 'adjustButton 'adjust-action "/local/restart32.png" "/local/restart-down32.png")
(gs:image-button 'clearButton 'clear-action "/local/clear32.png" "/local/clear-down32.png")
(gs:image-button 'closeButton 'close-action "/local/dotred32.png")
(gs:label 'LabelRow " Row ")
(gs:label 'LabelCol " Column ")
(gs:button 'insButtonRow 'insert-action "insert")
(gs:button 'delButtonRow 'delete-action "delete")
(gs:button 'insButtonCol 'insert-action "insert")
(gs:button 'delButtonCol 'delete-action "delete")
;(gs:image-button 'reLoadButton 'clear-action "/local/restart32.png" "/local/restart32-down32.png")
(gs:set-tool-tip 'newButton "new table")
(gs:set-tool-tip 'fileButton "open tsble")
(gs:set-tool-tip 'saveButton "save csv")
(gs:set-tool-tip 'adjustButton "adjust current table")
(gs:set-tool-tip 'clearButton "clear current table")
(gs:set-tool-tip 'closeButton "close current table")
(gs:add-to 'ButtonPanel 'newButton 'fileButton 'saveButton 'clearButton)
(gs:add-separator 'ButtonPanel)
(gs:add-to 'ButtonPanel 'clearButton)
(gs:add-to 'ButtonPanel 'closeButton)
(gs:add-separator 'ButtonPanel)
(gs:add-to 'ButtonPanel 'LabelRow 'insButtonRow 'delButtonRow)
(gs:add-separator 'ButtonPanel)
(gs:add-to 'ButtonPanel 'LabelCol 'insButtonCol 'delButtonCol)
(gs:add-to 'ButtonPanel 'adjustButton)
(gs:add-separator 'ButtonPanel)
(gs:menu 'fileMenu "File")
(gs:menu-item 'fileNew 'new-action "New table")
(gs:menu-item 'fileClose 'close-action "Close table")
(gs:menu-item 'fileOpen 'open-file-dialog "Open ...")
(gs:menu-item 'fileSave 'save-action "Save")
(gs:menu-item 'fileSaveAs 'save-file-dialog "Save As ...")
(gs:menu-item 'fileExit 'closed-window "Exit")
(gs:add-to 'fileMenu 'fileNew 'fileClose )
(gs:add-separator 'fileMenu)
(gs:add-to 'fileMenu 'fileOpen 'fileSave 'fileSaveAs)
(gs:add-separator 'fileMenu)
(gs:add-to 'fileMenu 'fileExit)
(gs:set-accelerator 'fileNew "shift ctrl N")
(gs:set-accelerator 'fileClose "ctrl W")
(gs:set-accelerator 'fileOpen "ctrl O")
(gs:set-accelerator 'fileSave "ctrl S")
(gs:set-accelerator 'fileSaveAs "shift ctrl S")
(gs:menu 'editMenu "Edit")
(gs:menu-item 'editCut 'edit-action "Cell Cut")
(gs:menu-item 'editCopy 'edit-action "Cell Copy")
(gs:menu-item 'editPaste 'edit-action "Cell Paste")
(gs:menu-item 'editCutRow 'cut-action "Row Cut")
(gs:menu-item 'editCopyRow 'copy-action "Row Copy")
(gs:menu-item 'editPasteRow 'paste-action "Row Paste")
(gs:menu-item 'editCutCol 'cut-action "Column Cut")
(gs:menu-item 'editCopyCol 'copy-action "Column Copy")
(gs:menu-item 'editPasteCol 'paste-action "Column Paste")
(gs:disable 'editPaste 'editPasteRow 'editPasteCol)
;(gs:set-accelerator 'editCut "ctrl X")
;(gs:set-accelerator 'editCopy "ctrl C")
;(gs:set-accelerator 'editPaste "ctrl V")
(gs:add-to 'editMenu 'editCut 'editCopy 'editPaste)
(gs:add-separator 'editMenu)
(gs:add-to 'editMenu 'editCutRow 'editCopyRow 'editPasteRow)
(gs:add-separator 'editMenu)
(gs:add-to 'editMenu 'editCutCol 'editCopyCol 'editPasteCol)
(gs:menu 'viewMenu "View")
(gs:menu-item 'viewAdjust 'adjust-action "adjust current table")
(gs:menu-item 'viewHTML 'dialog-action "to html-table")
(gs:menu-item 'viewList 'dialog-action "to lisp-list text")
(gs:add-to 'viewMenu 'viewAdjust 'viewHTML 'viewList)
(gs:menu-bar 'Frame 'fileMenu 'editMenu 'viewMenu)
(gs:menu-popup 'viewMenuPopup "View")
(gs:menu-item 'toolCopy 'clip-action "copy")
(gs:menu-item 'toolHTMLFile 'HTMLfile-action "to .html file")
(gs:add-to 'viewMenuPopup 'toolCopy 'toolHTMLFile)
(gs:tabbed-pane 'CSVtab 'tab-changed "top")
(new-action)
; mount all on frame
(gs:set-border-layout 'Frame)
(gs:add-to 'Frame 'ButtonPanel "north" 'CSVtab "center" 'StatusPanel "south")
(gs:window-resized 'Frame 'resize-action)
(gs:window-closed 'Frame 'closed-window)
(gs:set-visible 'Frame true)
; main routine
(gs:listen)
(exit)
新リスプな日々 
コメントを残す