home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
FreeWare Collection 3
/
FreeSoftwareCollection3pd199x-jp.img
/
oh_fm
/
pcmfact
/
pcmf.bas
< prev
next >
Wrap
BASIC Source File
|
1980-01-02
|
11KB
|
311 lines
1000 '
1010 ' The PCM Amplifier
1020 ' by J
1030 '
1040 '
1050 *INIT
1060 CLEAR ,,512,310000,1024: LOADM "pcmcalc.rex",0
1070 SCREEN@ 0: WIDTH 80,25:COLOR 0,7,7,4:CLS
1080 DIM LOADDATA%(50000),SAVEDATA%(50000),CUTSAVE%(50000)
1090 DIM CMDNAMES$(6),CMD_P(6,2),CMD_EN(6,3),PARAM_EN(4,3),PARAM(4)
1100 '
1110 '
1120 PARAM_NUM=4: CMD_NUM=6 :CUT_FLAG=0
1130 '
1140 '
1150 YESNO$="[yes=左クリック no=右クリック]"
1160 ON ERROR GOTO *ERROR
1170 '
1180 '
1190 RESTORE *COLOR
1200 FOR I=0 TO 15
1210 READ LOC0,LOC1,LOC2:PALETTE I,[LOC0,LOC1,LOC2]
1220 NEXT I
1230 '
1240 RESTORE *CMDNAMES
1250 FOR I=1 TO CMD_NUM
1260 READ CMDNAMES$(I),CMD_P(I,0),CMD_P(I,1)
1270 READ CMD_EN(I,0),CMD_EN(I,1),CMD_EN(I,2),CMD_EN(I,3)
1280 NEXT I
1290 '
1300 RESTORE *PARAM_TB
1310 FOR I=1 TO PARAM_NUM
1320 READ PARAM(I),PARAM_EN(I,0),PARAM_EN(I,1)
1330 READ PARAM_EN(I,2),PARAM_EN(I,3)
1340 NEXT I
1350 '
1360 MOUSE 0:MOUSE 1,20,20,1
1370 '
1380 ':::::::::::::::::::::::::::::::::::::::: Main Routine :::::::
1390 GOSUB *MAIN_MENU
1400 *MAIN_LOOP
1410 GOSUB *GET_MOUSE :IF ARG0=1 THEN *MAIN_LOOP
1420 GOSUB *GET_CMD_POSI
1430 IF CMD_IND=CMD_NUM THEN *QUIT
1440 IF CMD_IND=0 THEN *MN_SKIP
1450 CMD_SW=5: GOSUB *WRITE_CMD
1460 ON CMD_IND GOSUB *INPUT_PCM,*OUTPUT_PCM,*PLAY1,*ON_WORK,*PLAY2
1470 CMD_SW=4: GOSUB *WRITE_CMD: GOTO *MAIN_LOOP
1480 *MN_SKIP
1490 GOSUB *GET_ED_POSI
1500 IF CMD_IND<>0 THEN GOSUB *GET_PARAM
1510 GOTO *MAIN_LOOP
1520 '
1530 *QUIT
1540 TMSG$="終了します."+YESNO$
1550 GOSUB *WRITE_TMSG
1560 GOSUB *GET_MOUSE
1570 IF ARG0=1 THEN GOSUB *ERASE_TMSG:RETURN
1580 TMSG$=" Good Luck and Good Bye " : GOSUB *WRITE_TMSG
1590 MOUSE 5
1600 END
1610 ':::::::::::::::::::::::::::::::::::: End Main ::::::::::::::::::::
1620 '
1630 *MAIN_MENU
1640 CLS:LINE(1,1)-(638,478),PSET,%1,BF,%14
1650 CONNECT(60,340)-(60,20)-(240,120)-(240,20)-(410,120)-(410,20)-(600,120)-(600,340)-(60,340),%0,PSET,F,%13
1660 CONNECT(495,65)-(495,30)-(535,30)-(535,87),%0,PSET,F,%13
1670 LINE (70,200)-(230,320),PSET,%0,BF,%2
1680 LINE(250,200)-(410,320),PSET,%0,BF,%2
1690 LINE(430,200)-(590,320),PSET,%0,BF,%2
1700 SYMBOL (160,350) ," PCM factory ",3,3,%5,,,3
1710 LINE (50,350)-(160,410),PSET,%0,BF,%2
1720 LINE (480,350)-(590,410),PSET,%0,BF,%2
1730 LINE (20,365)- (50,410),PSET,%0,BF,%2
1740 LINE (590,365)-(620,410),PSET,%0,BF,%2
1750 CIRCLE (40,410),10,%0,,,,F,PSET,%2
1760 CIRCLE (140,410),10,%0,,,,F,PSET,%2
1770 CIRCLE (500,410),10,%0,,,,F,PSET,%2
1780 CIRCLE (600,410),10,%0,,,,F,PSET,%2
1790 SYMBOL (130,230),"Level" ,1,1,%5,,,3
1800 SYMBOL (130,250)," Adjust" ,1,1,%5,,,3
1810 SYMBOL (310,230),"Low Pass" ,1,1,%5,,,3
1820 SYMBOL (310,250)," Filter",1,1,%5,,,3
1830 SYMBOL (500,230),"Noise" ,1,1,%5,,,3
1840 SYMBOL (500,250)," Gate" ,1,1,%5,,,3
1850 SYMBOL ( 80,315),"0 50 100%",1,1,%5,1,,64
1860 SYMBOL (260,315),"0 50 100%",1,1,%5,1,,64
1870 SYMBOL (440,315),"0 50 100%",1,1,%5,1,,64
1880 SYMBOL (485,272),"0 50 100%",1,1,%5, ,,64
1890 GOSUB *WRITE_ALL_PARAM
1900 CMD_SW=4:GOSUB *WRITE_ALL_CMD
1910 GOSUB *ERASE_TMSG
1920 RETURN
1930 '
1940 '
1950 *PLAY1
1960 PCMPLAY LOADDATA%
1970 RETURN
1980 '
1990 *PLAY2
2000 PCMPLAY SAVEDATA%
2010 RETURN
2020 '
2030 *ON_WORK
2040 LEVEL&=0:P1&=64*PARAM(3)/100:P2&=PARAM(4)*192
2050 CALLM &HC9,VARPTR(LOADDATA%(0)),100000,VARPTR(SAVEDATA%(0))
2060 CALLM &H3D,VARPTR(SAVEDATA%(16)),COUNT&,VARPTR(LEVEL&)
2070 IF LEVEL&=0 THEN RETURN
2080 VOL=127/LEVEL&
2090 INT_VOL&=INT(VOL*256*PARAM(1)/100)
2100 CALLM &H0,VARPTR(SAVEDATA%(16)),COUNT&,INT_VOL&
2110 '
2120 P3&=INT(.44!*(100-PARAM(2)+1))
2130 '
2140 CALLM &HE4,VARPTR(SAVEDATA%(16)),COUNT&,P3&
2150 CALLM &H76,VARPTR(SAVEDATA%(16)),COUNT&,P1&,P2&
2160 RETURN
2170 '
2180 *REC
2190 TMSG$="録音します,準備ができたら左クリックしてください."
2200 GOSUB *WRITE_TMSG
2210 GOSUB *GET_MOUSE :IF ARG0=1 THEN NA$="illegal": RETURN
2220 NA$="Record"
2230 TMSG$="Recording" :GOSUB *WRITE_TMSG
2240 PCMREC LOADDATA%,19200
2250 TMSG$="終了しました."
2260 GOSUB *WRITE_TMSG
2270 RETURN
2280 '
2290 '
2300 *INPUT_PCM
2310 TMSG$=" 原料を指定してください [Input File Name] ":GOSUB *WRITE_TMSG
2320 LOCATE 46,23:LINE INPUT FULLNAME$:CLS 4
2330 IF FULLNAME$="" THEN *IP_SKIP
2340 IF FULLNAME$="RECORD" OR FULLNAME$="record" THEN GOSUB *REC:GOTO *IP_SKIP
2350 LOC0=INSTR(FULLNAME$,".")
2360 IF LOC0<>0 THEN FULLNAME$=LEFT$(FULLNAME$,LOC0)+"SND" ELSE FULLNAME$=FULLNAME$+".SND"
2370 ERASE LOADDATA%:DIM LOADDATA%(50000)
2380 LOAD@ FULLNAME$,LOADDATA%
2390 NA$=FULLNAME$:GOSUB *PASS_BREAK
2400 *IP_SKIP
2410 LINE(68,356)-(150,380),PSET,%0,BF,%2
2420 SYMBOL(70,360),NA$,1,1,%15,,,1
2430 LINE(488,356)-(570,380),PSET,%0,BF,%2
2440 SYMBOL(490,360),NA$,1,1,%15,,,1
2450 CALLM &HC9,VARPTR(LOADDATA%(0)),100000,VARPTR(SAVEDATA%(0))
2460 COUNT&=PEEK(VARPTR(LOADDATA%(6)),4)
2470 GOSUB *ERASE_TMSG
2480 RETURN
2490 '
2500 '
2510 *OUTPUT_PCM
2520 CUT_FLAG=0
2530 TMSG$=" 出荷先を指定してください [Input File Name] ":GOSUB *WRITE_TMSG
2540 LOCATE 46,23:LINE INPUT SAVENAME$:CLS 4
2550 IF SAVENAME$="" AND FULLNAME$="" THEN TMSG$="指定が無効です":GOTO *OP_SKIP
2560 IF SAVENAME$="" THEN SAVENAME$=FULLNAME$
2570 LOC0=INSTR(SAVENAME$,",")
2580 IF LOC0<>0 THEN A$=MID$(SAVENAME$,LOC0+1,1):SAVENAME$=LEFT$(SAVENAME$,LOC0-1)
2590 IF A$="C" OR A$="c" THEN CUT_FLAG=1
2600 LOC0=INSTR(SAVENAME$,".")
2610 IF LOC0<>0 THEN SAVENAME$=LEFT$(SAVENAME$,LOC0)+"SND" ELSE SAVENAME$=SAVENAME$+".SND"
2620 IF CUT_FLAG=0 THEN SAVE@ SAVENAME$,SAVEDATA% ELSE GOSUB *CUT_SAVE
2630 TMSG$=""
2640 *OP_SKIP
2650 GOSUB *WRITE_TMSG
2660 FOR I=1 TO 1000:NEXT I:GOSUB *ERASE_TMSG
2670 RETURN
2680 '
2690 *CUT_SAVE
2700 P3&=0
2710 CALLM &H196,VARPTR(SAVEDATA%(16)),COUNT&,VARPTR(P3&)
2720 IF P3&<>0 THEN *CS1
2730 TMSG$="デ-タは全てゼロクリアされていますのでセ-ブしても意味はありません"
2740 GOSUB *WRITE_TMSG:FOR I=1 TO 10000:NEXT I
2750 RETURN
2760 *CS1:
2770 ERASE CUTSAVE%:DIM CUTSAVE%(INT(P3&/2+17))
2780 CALLM &HC9,VARPTR(SAVEDATA%(0)),P3&+32,VARPTR(CUTSAVE%(0))
2790 POKE VARPTR(CUTSAVE%(6)),P3&,4:POKE VARPTR(CUTSAVE%(8)),0,4
2800 SAVE@ SAVENAME$,CUTSAVE%
2810 RETURN
2820 '
2830 ':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
2840 '
2850 '
2860 *GET_MOUSE '**/ RET. IS arg0,arg1,arg2 is botten,X,Y
2870 IF MOUSE (2,0) THEN ARG0=0::GOTO *M_ON
2880 IF MOUSE (2,1) THEN ARG0=1: GOTO *M_ON
2890 GOTO *GET_MOUSE
2900 *M_ON
2910 IF MOUSE(2,ARG0) THEN *M_ON
2920 ARG1=MOUSE(4,ARG0):ARG2=MOUSE(5,ARG0)
2930 RETURN
2940 '
2950 *GET_CMD_POSI
2960 CMD_IND=0
2970 FOR I=1 TO CMD_NUM
2980 IF NOT(ARG1>CMD_EN(I,0) AND ARG1< CMD_EN(I,1)) GOTO *GET_CMD_LOOP
2990 IF ARG2>CMD_EN(I,2) AND ARG2<CMD_EN(I,3) THEN CMD_IND=I:RETURN
3000 *GET_CMD_LOOP
3010 NEXT I
3020 CMD_IND=0
3030 RETURN
3040 '
3050 *GET_ED_POSI
3060 CMD_IND=0
3070 FOR I=1 TO PARAM_NUM
3080 IF NOT(ARG1>PARAM_EN(I,0) AND ARG1< PARAM_EN(I,1)) GOTO *GET_CMD_LOOP
3090 IF ARG2>PARAM_EN(I,2) AND ARG2<PARAM_EN(I,3) THEN CMD_IND=I:RETURN
3100 *GET_CMD_LOOP
3110 NEXT I
3120 CMD_IND=0
3130 RETURN
3140 '
3150 *GET_PARAM
3160 IF CMD_IND=4 PARAM(4)=ARG1-PARAM_EN(4,0):GOTO *GP_SKIP
3170 PARAM(CMD_IND)=PARAM_EN(CMD_IND,3)-ARG2
3180 *GP_SKIP
3190 IF PARAM(CMD_IND)>95 THEN PARAM(CMD_IND)=100
3200 IF PARAM(CMD_IND)<3 THEN PARAM(CMD_IND)=0
3210 GOSUB *WRITE_PARAM
3220 RETURN
3230 '
3240 '
3250 *WRITE_ALL_CMD '**/ (cmd_sw is color)
3260 FOR CMD_IND=1 TO CMD_NUM
3270 GOSUB *WRITE_CMD
3280 NEXT CMD_IND
3290 RETURN
3300 '
3310 *WRITE_CMD '**/ (cmd_ind is index, cmd_sw is color)
3320 LINE(CMD_EN(CMD_IND,0),CMD_EN(CMD_IND,2))-(CMD_EN(CMD_IND,1),CMD_EN(CMD_IND,3)),PSET,%0,BF,%2
3330 SYMBOL(CMD_P(CMD_IND,0),CMD_P(CMD_IND,1)),CMDNAMES$(CMD_IND),1,1,%CMD_SW,,,1
3340 RETURN
3350 '
3360 '
3370 *WRITE_ALL_PARAM
3380 FOR I=1 TO PARAM_NUM
3390 GOSUB *WRITE_PARAM
3400 NEXT I
3410 RETURN
3420 '
3430 *WRITE_PARAM '**/ (arg. is I)
3440 LINE(PARAM_EN(I,0),PARAM_EN(I,2))-(PARAM_EN(I,1),PARAM_EN(I,3)),PSET,%0,BF,%15
3450 IF I=4 THEN LINE(PARAM_EN(I,0),PARAM_EN(I,2))-(PARAM_EN(I,0)+PARAM(I),PARAM_EN(I,3)),PSET,%0,BF,%4:RETURN
3460 LINE(PARAM_EN(I,0),PARAM_EN(I,3))-(PARAM_EN(I,1),PARAM_EN(I,3)-PARAM(I)),PSET,%0,BF,%4
3470 RETURN
3480 '
3490 *WRITE_TMSG
3500 LINE(6,430)-(633,458),PSET,%0,BF,%15
3510 SYMBOL (17,437),TMSG$,1,1,%0,,,1
3520 RETURN
3530 '
3540 *ERASE_TMSG
3550 LINE(6,430)-(633,458),PSET,%0,BF,%15
3560 RETURN
3570 '
3580 '
3590 *PASS_BREAK
3600 LOC1=LEN(FULLNAME$):LOC0=0
3610 IF MID$(FULLNAME$,2,1)=":" THEN NA$=MID$ (FULLNAME$,3)
3620 FOR I=1 TO LOC1
3630 IF MID$ (NA$,I,1) = "\" THEN LOC0=I
3640 NEXT I
3650 NA$=MID$(NA$,LOC0+1)
3660 LOC0=INSTR(NA$,".")
3670 IF LOC0 <>0 THEN NA$=LEFT$(NA$,LOC0-1)
3680 RETURN
3690 '
3700 '
3710 '
3720 *CMDNAMES
3730 DATA "原料" , 70,390, 65,105,388,408
3740 DATA "出荷" ,530,390,525,565,388,408
3750 DATA "原料検査",120,152,100,200,150,170
3760 DATA " 製造" ,300,152,280,380,150,170
3770 DATA "製品検査",480,152,460,560,150,170
3780 DATA "倒産" , 10, 20, 5, 45, 18, 38
3790 *PARAM_TB
3800 DATA 80,100,120,210,310
3810 DATA 80,280,300,210,310
3820 DATA 20,460,480,210,310
3830 DATA 80,485,585,290,310
3840 *COLOR
3850 DATA 0, 0, 0, 0, 0,128,200,200,200,200,200,200
3860 DATA 128, 0, 0,128, 0,128,128,128, 0,128,128,128
3870 DATA 64, 64, 64, 0, 0,255, 0,255, 0, 0,255,255
3880 DATA 255, 0, 0,255, 0,255,255, 0, 0,255,255,255
3890 '
3900 *ERROR
3910 IF ERR=64 THEN *ERROR1
3920 IF ERR=53 THEN *ERROR2
3930 GOTO *ERROR3
3940 *ERROR1
3950 TMSG$="すでにファイルがあります,オ-バ-ライトしますか"+YESNO$
3960 GOSUB *WRITE_TMSG
3970 GOSUB *GET_MOUSE
3980 IF ARG0=1 THEN RESUME NEXT ELSE KILL SAVENAME$:RESUME
3990 *ERROR2
4000 TMSG$="入出力装置に異常が発生したそうです。ファイル名を調べてください"
4010 GOSUB *WRITE_TMSG:GOSUB *GET_MOUSE
4020 NA$="":FULLNAME$=""
4030 RESUME NEXT
4040 *ERROR3:TMSG$="Error No. "+STR$(ERR)+" in "+STR$(ERL)+" マウスをクリックしてください"
4050 GOSUB *WRITE_TMSG: GOSUB *GET_MOUSE: GOSUB *ERASE_TMSG
4060 RESUME NEXT
4070 '
4080 '
4090 ':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::