[Python]help関数とpydoc

Pythonの情報を得たい場合、help関数やpydocコマンドが便利なようです。
 ドキュメントの調べ方を知っていると、ググれない空間にとらわれても安心ですね。 

Pythonインタプリタでhelp("モジュール名やキーワード、トピック")としてhelp関数を呼び出すと、 対応するドキュメントが閲覧できます。

# ビルトイン関数のドキュメントを表示
>>> help("__builtin__")
# open関数のドキュメントを表示
>>> help("open")

pydocコマンドを使うとhelp関数と同じようなドキュメント閲覧をコマンドラインから行えます。

# モジュールのドキュメントを表示
pydoc glob
pydoc ctypes
# モジュール一覧を表示
pydoc modules
# キーワード一覧を表示(with,raiseなど)
pydoc keywords
# シンボル一覧を表示(+, u"など)
pydoc symbols
# トピック一覧を表示(DEBUGGING, LOOPINGなど)
pydoc topics

また、pydocはオプションを指定することでドキュメントをHTML形式にして出力したり、 Webサーバーを立ち上げてブラウザで閲覧できるようにしてくれたりするようです。

# ポート番号を指定してWebサーバーを起動
pydoc -p 9999
# HTMLで出力
pydoc -w os

[CL]Windowsでselect

CCL + CFFIでWindows上でselectしてみます。

(asdf:load-system :usocket)
(asdf:load-system :bordeaux-threads)
(asdf:load-system :cffi)

(defconstant FD-SETSIZE 64)

(cffi:defcstruct timeval
  (tv-sec :ulong)
  (tv-usec :ulong))

(cffi:defcstruct fd-set
  (fd-count :uint)
  (fd-array :uint :count 64))

(cffi:defcfun ("select" win-select) :int
  (nfds :int)
  (readfds :pointer)
  (writefds :pointer)
  (exceptfds :pointer)
  (timeout :pointer))

(defun fd-zero (set)
  (setf (cffi:foreign-slot-value set 'fd-set 'fd-count) 0))

(defun fd-set (fd set)
  (when (< (cffi:foreign-slot-value set 'fd-set 'fd-count) FD-SETSIZE)
    (setf (cffi:mem-aref (cffi:foreign-slot-pointer set 'fd-set 'fd-array)
    :uint
    (cffi:foreign-slot-value set 'fd-set 'fd-count))
   fd)
    (incf (cffi:foreign-slot-value set 'fd-set 'fd-count))))

(defun fd-isset (fd set)
  (cffi:foreign-funcall "__WSAFDIsSet" :uint fd ::pointer set :int))

(defun fd-clr (fd set)
  (loop
     :with count = (cffi:foreign-slot-value set 'fd-set 'fd-count)
     :with i = 0
     :while (<  i count)
     :if (= (cffi:mem-aref (cffi:foreign-slot-pointer set 'fd-set 'fd-array) :uint i) fd)
     :do (loop :while (< i (1- count))
     :do
     (setf (cffi:mem-aref (cffi:foreign-slot-pointer set 'fd-set 'fd-array) :uint i)
    (cffi:mem-aref (cffi:foreign-slot-pointer set 'fd-set 'fd-array) :uint (1+ i)))
     (incf i))
     (decf count)
     :else
     :do (incf i)
     :finally (setf (cffi:foreign-slot-value set 'fd-set 'fd-count) count)))


(defun test ()
  (let* ((listener (usocket:socket-listen "localhost" 8888 :reuse-address t))
  (listener-fd (ccl:socket-os-fd (usocket:socket listener)))
  (fds (list listener-fd))
  (fd-obj `((,listener-fd ,listener))))
    (format t "Listener Fd:~A~%" listener-fd)
  (cffi:with-foreign-object (set 'fd-set)
    (loop
       (fd-zero set)
       (dolist (fd fds) (fd-set fd set))
       (unless (= 0 (win-select
       (apply #'max fds)
       set
    (cffi:null-pointer) (cffi:null-pointer) (cffi:null-pointer)))
  (dolist (fd fds)
    (when (fd-isset fd set)
      (if (= fd listener-fd)
   (let* ((sock (usocket:socket-accept listener))
   (sock-fd (ccl:socket-os-fd (usocket:socket sock))))
     (format t "Accept~%")
     (force-output t)
     (push sock-fd fds)
     (push (list sock-fd sock) fd-obj))
   (progn
     (format t "ReadLine:~A~%"
      (read-line (usocket:socket-stream (second (assoc fd fd-obj)))))
     (force-output t))))))))))


;; (defparameter th (bordeaux-threads:make-thread #'test))
;; (defparameter *con* (usocket:socket-connect "localhost" 8888))
;; (format (usocket:socket-stream *con*) "Hello, World~%")
;; (force-output (usocket:socket-stream *con*))
;; (bordeaux-threads:destroy-thread th)

[Racket]クリップボードにある画像をファイルに保存する

クリップボードにあるデータが画像である場合に、ファイルに保存させてみます。

#lang racket

(require racket/gui/base
  (prefix-in srfi19: srfi/19))

(define (make-filename)
  (format "~A~A.png"
   "C:/path_to_save_dir/"
   (srfi19:date->string
    (srfi19:current-date)
    "~Y~m~d_~H~M~S_~N")))

(define (save-clipboard-bitmap)
  (let ((bm (send the-clipboard get-clipboard-bitmap 0)))
    (and bm
  (send bm save-file (make-filename) 'png))))

(exit
 (if (save-clipboard-bitmap) 0 1))

AutoHotKeyを使って適当なキーにこのプログラムの実行を割り当てれば、 PrintScreen+ファイル保存を1つのキーで実行できます。
実行可能ファイルの作成は raco exe や raco distribute で行えます。

> raco exe capture.rkt
> raco distribute directory_name capture.exe

Numpad0::                      ; テンキーの「0」に割り当て
  Send, {PrintScreen}          ; PrintScreen実行
  Run, "C:/path_to_exe_dir/capture.exe" ; プログラム実行
  Return

[Racket]MzCOMを利用してPowerShellからRacketを利用する

MzCOMを利用するとRacketをCOMオブジェクトとして利用できます。
たとえば以下のようにしてPowerShellからRacketの関数を呼び出せます。

$a = New-Object -ComObject "MzCOM.MzObj"
$a.Eval('(require racket/gui)')
$a.Eval('(message-box "title" "MzCom ")')

ただし、文字コードの扱いがうまくできていないっぽいです(バージョン5.2.1)

[Racket]OpenGLでテクスチャ

球にテクスチャを貼り付けてみます。掲示板やgistにあったコードを参考にしました。

#lang racket

(require sgl sgl/gl sgl/gl-vectors)
(require racket/gui)

;; argbをrgbaに変換
(define (argb->gl-rgba argb)
  (let* ((len (bytes-length argb))
   (buf (make-gl-ubyte-vector len)))
    (for ((i (in-range 0 len 4)))
  (gl-vector-set! buf (+ i 0) (bytes-ref argb (+ i 1)))
  (gl-vector-set! buf (+ i 1) (bytes-ref argb (+ i 2)))
  (gl-vector-set! buf (+ i 2) (bytes-ref argb (+ i 3)))
  (gl-vector-set! buf (+ i 3) (bytes-ref argb (+ i 0))))
    buf))

;; bitmapからargbのバイト列を取得
(define (bm->argb bm)
  (let* ((w (send bm get-width))
  (h (send bm get-height))
  (mask (send bm get-loaded-mask))
  (buf (make-bytes (* w h 4) 255)))
    (send bm get-argb-pixels 0 0 w h buf #f)
    (when mask
      (send bm get-argb-pixels 0 0 w h buf #t))
    buf))

;; テクスチャ読み込み
(define (load-texture path)
  (gl-enable 'texture-2d)
  (let* ((bm (make-object bitmap% path))
  (w (send bm get-width))
  (h (send bm get-height))
  (vec (argb->gl-rgba (bm->argb bm)))
  (tex (gl-vector-ref (glGenTextures 1) 0)))
    (glBindTexture GL_TEXTURE_2D tex)
    (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR)
    (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR)
    (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP)
    (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP)
    (gluBuild2DMipmaps GL_TEXTURE_2D GL_RGBA w h GL_RGBA GL_UNSIGNED_BYTE vec)
    tex))

(define current-texture #f)


;; OpenGLによる描画
(define (draw-gl)
  (gl-clear 'color-buffer-bit)
  (gl-push-matrix)
  (glBindTexture GL_TEXTURE_2D current-texture)
  (let ((q (gl-new-quadric))
 (list-id (gl-gen-lists 1)))
    (gl-quadric-texture q #t)
    (gl-quadric-draw-style q 'fill)
    (gl-new-list list-id 'compile)
    (gl-sphere q 0.5 20 20)
    (gl-end-list)
    (gl-call-list list-id))
  (gl-pop-matrix)
  (gl-flush))

(define gl-canvas%
  (class* canvas% ()
    (inherit with-gl-context swap-gl-buffers)
    ;; on-paintをオーバーライド
    (define/override (on-paint)
      (with-gl-context
       (lambda ()
  (draw-gl)
  (swap-gl-buffers))))
    ;; on-sizeをオーバーライド
    (define/override (on-size w h)
      (with-gl-context
       (lambda ()
  (gl-viewport 0 0 w h))))
    
    ;; canvas%のスタイルにglを指定
    (super-new [style '(gl)])))

(define top-level-frame
  (new frame%
       [label "OpenGL test"]
       [width 400]
       [height 400]))

(define canvas
  (new gl-canvas%
       [parent top-level-frame]))

(set! current-texture
 (send canvas with-gl-context
       (lambda () (load-texture "./texture.jpg"))))

(send top-level-frame show #t)

[Racket]GUIの中でOpenGLを利用する

RacketのGUIでは、canvas%クラスを利用してOpenGLによる描画を行えます。

#lang racket

(require sgl sgl/gl sgl/gl-vectors)
(require racket/gui)

;; OpenGLによる描画.
;; 関数やパラメータの形式にはRacket-StyleとC-Styleがある.
(define (draw-gl)
  (gl-clear 'color-buffer-bit)
  (gl-color 1.0 1.0 0.0)
  (gl-begin 'line-loop)
  (gl-vertex -0.9 -0.9)
  (gl-vertex 0.9 -0.9)
  (gl-vertex-v (gl-float-vector 0.9 0.9))
  (gl-vertex -0.9 0.9)
  (gl-end)
  (gl-flush))

(define gl-canvas%
  (class* canvas% ()
    (inherit with-gl-context swap-gl-buffers)
    ;; on-paintをオーバーライド
    (define/override (on-paint)
      (with-gl-context
       (lambda ()
  (draw-gl)
  (swap-gl-buffers))))
    ;; canvas%のスタイルにglを指定
    (super-new [style '(gl)])))

(define top-level-frame
  (new frame%
       [label "OpenGL test"]
       [width 400]
       [height 400]))

(define canvas
  (new gl-canvas%
       [parent top-level-frame]))

(send top-level-frame show #t)

gccの拡張機能無効化

日ごろ書いているのは'正しい'Cではない可能性が高いということに気付きました。 gccで拡張機能を無効にするには-pedanticオプションをつければよいようです。

gcc -pedantic test.c

[PowerShell]ExcelのシートをCSV形式で保存する

Excelのファイル中の各シートをCSV形式で保存します。

$xl = New-Object -ComObject Excel.Application
$xCSV = 6
$i = 0
$wb = $xl.Workbooks.Open("file")
foreach($sh in $wb.Sheets){
  $sh.Select()
  $wb.SaveAs("file" + $i + ".csv", $xCSV)
  $i += 1
}
$wb.Close()
$xl.Quit()

FFIを利用してWindows上でメッセージボックスを表示する

FFI(Foreign Function Interface)を利用して、Windows上でメッセージボックスを表示してみます。

注意点

• APIにはAscii用のMessageBoxAとUnicode用のMessageBoxWがある
• Unicodeの符号化形式はUTF-16LE

Common Lisp

FFIは処理系依存です。各処理系の差異を吸収してくれる、CFFIというライブラリがあります。 CFFIはQuicklispでインストール可能です。 文字列のエンコードを直接指定しない場合は, cffi:*default-foreign-encoding* に設定されている値が利用されます。

;; ffi-test.lisp
(asdf:load-system :cffi)

(defpackage :ffi-test
  (:use :cl :cffi)
  (:export message-box))

(in-package :ffi-test)

(load-foreign-library "user32.dll")

(defcfun ("MessageBoxW" message-box) :int32
  (hWnd :pointer)
  (lpText (:string :encoding :utf-16le))
  (lpCaption (:string :encoding :utf-16le))
  (uType :uint))

> (load "ffi-test.lisp")
> (ffi-test:message-box (cffi:null-pointer) "hello" "わーるど" 0)

または

(cffi:foreign-funcall 
   "MessageBoxW"
   :pointer (cffi:null-pointer)
   (:string :encoding :utf-16le) "hello"
   (:string :encoding :utf-16le) "わーるど"
   :uint 0
   :int32)

Racket

Racketではffi/unsafeライブラリを利用すればよさそうです。

#lang racket
;; ffi-test.rkt
(require ffi/unsafe)
(provide message-box)

(define user32 "user32.dll")

(define message-box
  (get-ffi-obj
   "MessageBoxW" user32
   (_fun _pointer
  _string/utf-16
  _string/utf-16
  _uint32
  -> _int32)
   #f))

> (load "ffi-test.rkt")
> (require 'ffi-test)
> (message-box #f "hello" "わーるど" 0)

Ruby

RubyでWindowsのDLLの関数を呼び出すには、Win32APIライブラリを利用すればよさそうです。

# -*- coding: utf-8 -*-
require "Win32API"
require "nkf"

class String
  def to_utf16le
    NKF.nkf("-w16L0", self)
  end
end

msgbox = Win32API.new('user32', 'MessageBoxW', %w(p p p i), 'i')
msgbox.call(0, "hello".to_utf16le, "わーるど".to_utf16le, 0)

Python

Pythonではctypesライブラリを利用すればよさそうです。

# -*- coding: utf-8 -*-
import ctypes

user32 = ctypes.windll.user32

user32.MessageBoxW(None, "hello", "わーるど", 0)

[Common Lisp] cl-annotで契約による設計のようななにか

cl-annotのアノテーションを利用して、契約による設計(Design By Contrat)っぽいことを行ってみます。

(asdf:load-system :cl-annot)
(asdf:load-system :alexandria)

(defpackage net.phorni.contract
  (:use :cl)
  (:export
   ;; annotation
   contract
   ;; condtion
   contract-error
   pre-contract-error
   post-contract-error
   ;; macro
   with-contract
   def/contract))

(in-package :net.phorni.contract)

(define-condition contract-error (error)
  ((expr :reader contract-expr :initarg :expr))
  (:report (lambda (condition stream)
      (format stream
       "~A: ~A"
       (type-of condition)
       (contract-expr condition)))))
(define-condition pre-contract-error (contract-error)
  ())
(define-condition post-contract-error (contract-error)
  ())

;; type-specifierの判別は処理系依存らしい
(defun type-specifier-p (x)
  (or
   #+CCL (ccl:type-specifier-p x)))

(defmacro contract-check (contract-type expr)
  (let ((gsym (gensym)))
    `(let ((,gsym ,expr))
       (if ,gsym
    ,gsym
    (error ,contract-type
    :expr ',expr)))))

(defun parse-contract-body (body)
  (loop
     :for expr in body
     :if (and (listp expr) (eq :pre (car expr)))
     :collect expr into pre
     :else :if (and (listp expr) (eq :post (car expr)))
     :collect expr into post
     :else
     :collect expr into parsed-body
     :finally (return (list pre post parsed-body))))

(defun pre-contract-expand (pre-list)
  `(progn
     ,@(loop
   :for pre in pre-list
   :collect
   `(contract-check 'pre-contract-error ,(second pre)))))

(defun post-contract-expand (vars post-list)
  `(progn
     ,@(loop
   :for post in post-list
   :collect
   `(contract-check 'post-contract-error
      (apply
       (lambda ,(cadr post)
         ,@(cddr post))
       ,vars)))))

(defmacro with-contract (&body body)
  (destructuring-bind
 (pre post parsed-body)
      (parse-contract-body body)
    (let ((gtmp (gensym)))
      `(progn
  ,(pre-contract-expand pre)
  (let ((,gtmp (multiple-value-list (progn ,@parsed-body))))
    ,(post-contract-expand gtmp post)
    (values-list ,gtmp))))))

(defun multiple-value-result-contract-spec? (x)
  (and (listp x)
       (eq :values (car x))
       (every #'type-specifier-p (cdr x))))

(defun check-multiple-value-num (result num)
  (= (length result) num))

(defmacro def/contract ((&rest args-contract) result-contract orig-def)
  (dolist (a args-contract)
    (unless (and (listp a)
   (= (length a) 2)
   (symbolp (first a))
   (type-specifier-p (second a)))
      (error "invalid pre-contract spec: ~A" a)))
  (when (and (not (multiple-value-result-contract-spec? result-contract))
      (type-specifier-p result-contract))
    (setf result-contract (list :values result-contract)))
  (unless (multiple-value-result-contract-spec? result-contract)
    (error "invalid post-contract spec: ~A" result-contract))  
  (let ((def (nth 0 orig-def))
 (name (nth 1 orig-def))
 (args (nth 2 orig-def))
 (body (nthcdr 3 orig-def))
 (gresult (gensym)))
    (multiple-value-bind
   (parsed-body declares doc)
 (alexandria:parse-body body :documentation t)
      `(,def ,name ,args
  ,doc
  ,@declares
  (with-contract
    ,@(loop
  :for a in args-contract
  :collect `(:pre (typep ,(first a) ',(second a))))
    (:post (&rest ,gresult)
    (and (check-multiple-value-num 
   ,gresult
   ,(length (cdr result-contract)))
         (every #'identity 
         (mapcar #'typep 
          ,gresult
          ',(cdr result-contract)))))
    ,@parsed-body)))))

(cl-annot:defannotation contract (args result def) (:arity 3)
  `(def/contract ,args ,result ,def))

;; ex

(def/contract ((n (integer 0 *)) (m (integer 1 *))) number
  (defun my-div-1 (n m)
    (/ n m)))
;; (my-div-1 2 3) => 2/3
;; (my-div-1 -1 1) => PRE-CONTRACT-ERROR: (TYPEP N '(INTEGER 0 *))

(cl-annot:enable-annot-syntax)

@contract ((n (integer 0 *)) (m (integer 1 *))) number
(defun my-div-2 (n m)
  (/ n m))
;; (my-div-2 4 2) => 2
;; (my-div-2 4 0) => PRE-CONTRACT-ERROR: (TYPEP M '(INTEGER 1 *))