(以下のスクリプトには、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))
(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))
(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))

; 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)
(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 -->
<table border="1">
(define tableROW '("<tr>" "</tr>"))
(define tableDATA '("<td align=\"right\">" "</td>"))
(define tableHEADER '("<th>" "</th>"))
(define *footer* [text]</table>
(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
            (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))))
           (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)
        (gs:confirm-dialog 'Frame
                           "close CSV file"
                           (string "Abandon unsaved " (get-filename))
(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 CSV Editor"
                         "Quit and lose unsaved content ?" 
(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
(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")
; 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

No comments yet



WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト / 変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト / 変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト / 変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト / 変更 )

%s と連携中