#!/usr/bin/newlisp
#---------------------------------------------------------------------------
# Manage permissions
#---------------------------------------------------------------------------
# Linux, Solaris: ioperm
# OpenBSD: i386_set_ioperm
# FreeBSD: open "/dev/io"
# DOS: access granted
# Windows 95, 98, ME: access granted
# Windows NT, 2000, XP: use kernel driver, for example:
#    http://www.embeddedtronics.com/public/Electronics/directio/directio.zip
#---------------------------------------------------------------------------
# May 21, 2006 - PvE.
#---------------------------------------------------------------------------

(context 'SPEAKER)

;Setup tone
;----------
;push eax    
;push epb
;mov al, 0xB6
;out 43h, al		{Write timer mode register}
;mov  ebp, esp
;mov  ax, [ebp+0c]	{Send frequency}
;out 42h, al
;mov al, ah
;out 42h, al		{Write timer a Byte at a time}
;in  al, 61h
;or  al, 3
;out 61h, al		{port B-switch speaker on}
;pop epb
;pop eax
;ret
(set 'tone-asm (pack "cccccccccc cccccccccc ccccccc" 0x50 0x55 0xb0 0xb6 0xe6 0x43 0x89 0xe5 0x66 0x8b
		    0x45 0x0c 0xe6 0x42 0x88 0xe0 0xe6 0x42 0xe4 0x61 0x0c 0x03 0xe6 0x61 0x5d 0x58 0xc3))

;Switch off
;----------
;push eax      
;in  al, 0x61
;and al, 0xFC		{Put bits 0,1 to 0}
;out 0x61, al
;pop eax
;ret
(set 'silence-asm (pack "ccccccccc" 0x50 0xe4 0x61 0x24 0xfc 0xe6 0x61 0x58 0xc3))

;Alternate
;----------
;push eax      
;in  al, $61
;xor al, 2		{Alternate between on/off}
;out $61, al
;pop eax
;ret
(set 'click-asm (pack "ccccccccc" 0x50 0xe4 0x61 0x34 0x02 0xe6 0x61 0x58 0xc3))

# Now create newLisp functions
(set 'tone print)
(set 'silence print)
(set 'click print)

(case (last (sys-info))
    # Windows
    (6
	(cpymem (pack "ld" 265) (first (dump tone)) 4)
	(cpymem (pack "ld" 265) (first (dump silence)) 4)
	(cpymem (pack "ld" 265) (first (dump click)) 4)
    )
    # Other OS
    (true
	(cpymem (pack "ld" 264) (first (dump tone)) 4)
	(cpymem (pack "ld" 264) (first (dump silence)) 4)
	(cpymem (pack "ld" 264) (first (dump click)) 4)
    )
)

(cpymem (pack "ld" (address tone-asm)) (+ (first (dump tone)) 12) 4)
(cpymem (pack "ld" (address silence-asm)) (+ (first (dump silence)) 12) 4)
(cpymem (pack "ld" (address click-asm)) (+ (first (dump click)) 12) 4)

# Frequences for tones, 3 scales
(set 'scale1 '(9121 8609 8126 7670 7239 6833 6449 6087 5746 5423 5119 4831 4560))
(set 'scale2 '(4560 4304 4063 3834 3619 3416 3224 3043 2873 2711 2559 2415 2280))
(set 'scale3 '(2280 2152 2031 1917 1809 1715 1612 1521 1436 1355 1292 1207 1140))

(define (help)
    (println)
    (println "This context manages the PC-speaker in an X86-generic way.")
    (println)
    (println "On Unix platforms, you must have root rights to use it.")
    (println "You can set the SUID bit on the newLisp binary to have low-level")
    (println "hardware access.")
    (println)
    (println "On WinNT, 2000 and XP a special IO-driver is required.")
    (println "Drivers can be found here: http://www.embeddedtronics.com/design&ideas.html")
    (println)
)

#-------------------------------------------

(context 'MAIN)

# Setup permissions for ports 0x42, 0x43 and 0x61
(import "libc.so.6" "ioperm")
(ioperm 0x61 1 1)
(ioperm 0x42 2 1)

(SPEAKER:help)

# Setup piano on keyboard
(set 'piano '((113 4560)(50 4304)(119 4063)(51 3834)(101 3619)(114 3416)(53 3224)(116 3043)(54 2873)(121 2711)(55 2559)(117 2415)(105 2280)
      (122 2280)(115 2152)(120 2031)(100 1917)(99 1809)(118 1715)(103 1612)(98 1521)(104 1436)(110 1355)(106 1292)(109 1207)(44 1140)))

(println "Press keys to play the piano! ESC to exit.")

(while (!= (set 'c (read-key)) 27)
    (lookup c piano)
    (if (!= (lookup c piano) nil)(SPEAKER:tone (lookup c piano)))
    (sleep 200)
    (SPEAKER:silence))

(SPEAKER:silence)
(exit)