PROCedimientos y FuNciones
Moderador: Sir Cilve Sinclair
- badaman
- Sabreman
- Mensajes: 499
- Registrado: Mar Ene 29, 2008 10:58 am
- Contactar:
PROCedimientos y FuNciones
Inicio aquí un hilo para ir recopilando todos aquellos procedimientos y funciones que pueden ser de utilidad a un programador de SuperBASIC.
Este hilo tiene la doble "función" de servir de recordatorio para la programación y de aprendizaje para los que se acerquen por primera vez al SuperBASIC.
Básicamente aquí lo que encontrarás son rutinas de programación que buenamente pudieron haberse escrito para otros lenguajes estructurados pero que han sido creadas o adaptadas al lenguaje por defecto del QL.
Así que, si tienes alguna rutina de la que te sientas especialmente satisfecho, o simplemente quieres recordar tus momentos de gloria con el teclado, pues sólo tienes que seguir el hilo.
Este hilo tiene la doble "función" de servir de recordatorio para la programación y de aprendizaje para los que se acerquen por primera vez al SuperBASIC.
Básicamente aquí lo que encontrarás son rutinas de programación que buenamente pudieron haberse escrito para otros lenguajes estructurados pero que han sido creadas o adaptadas al lenguaje por defecto del QL.
Así que, si tienes alguna rutina de la que te sientas especialmente satisfecho, o simplemente quieres recordar tus momentos de gloria con el teclado, pues sólo tienes que seguir el hilo.
Sinclair QL, la respuesta profesional de los 80
-
- Sabreman
- Mensajes: 396
- Registrado: Dom Feb 24, 2008 10:56 pm
Re: PROCedimientos y FuNciones
Algunas funciones y procedimientos clásicos que usan la recursividad como estrategia de solución.
Autor: Dilwyn Jones
Mas info en: http://217.126.211.48/DocsQL/Recursividad.pdf
Exploración de directorios.
Un clásico, algorítmo de ordenación quicksort
Otro clásico en el estudio de la recursividad, puzzle Torres de Hanoi
Autor: Dilwyn Jones
Mas info en: http://217.126.211.48/DocsQL/Recursividad.pdf
Exploración de directorios.
Código: Seleccionar todo
100 REMark extended dir of all sub-directories
110 Extended_DIR 'win1_',''
120 :
130 DEFine PROCedure Extended_DIR (drive$,directory$)
140 LOCal loop,ch,d$,fp,n$
150 ch = FOP_DIR (drive$&directory$) : REMark open channel to
directory
160 IF ch < 0 THEN RETurn : REMark unable to open directory
170 fp = 14 : REMark file position in directory for filename
180 REPeat loop
190 BGET #ch: IF EOF(#ch) THEN CLOSE #ch : EXIT loop
200 GET #ch,d$ : REMark get directory entry name
210 IF LEN(d$) > 0 THEN
220 REMark a directory length of 0 may be a deleted file
230 BGET #ch: REMark file type byte
240 IF CODE(INKEY$(#ch)) = 255 THEN
250 REMark this name is a subdirectory, so we need to DIR this
260 REMark if you want directory names printed, add this
270 REMark PRINT d$;' ->'
280 Extended_DIR drive$,d$
290 ELSE
300 PRINT d$
310 END IF
320 END IF
330 fp = fp + 64
340 END REPeat loop
350 END DEFine Extended_DIR
Un clásico, algorítmo de ordenación quicksort
Código: Seleccionar todo
100 Q_Sort array_name$,0,entries%-1
110 :
120 DEFine PROCedure Q_Sort (array$,bottom,top)
130 LOCal sort_loop,low,high,ptr
140 low = bottom
150 high = top
160 ptr = bottom
170 REPeat sort_loop
180 IF low >= high THEN EXIT sort_loop
190 IF array$(low) > array$(high) THEN
200 REMark need to swap these strings
210 temp$ = array$(low)
220 array$(low) = array$(high)
230 array$(high) = temp$
240 REMark how do we shuffle pointers to sections
250 IF ptr = low THEN
260 low = low + 1
270 ptr = high
280 ELSE
290 high = high - 1
300 ptr = low
310 END IF
320 ELSE
330 IF ptr = low THEN high = high - 1 : ELSE low = low + 1
340 END IF
350 END REPeat sort_loop
360 IF ABS(top - bottom) < 2 THEN RETurn : REMark can't sort 1 item!
370 Q_Sort array$,bottom,ptr - 1
380 Q_Sort array$,ptr + 1,top
390 END DEFine Q_Sort
Otro clásico en el estudio de la recursividad, puzzle Torres de Hanoi
Código: Seleccionar todo
100 REMark Towers of Hanoi puzzle
110 INPUT'How many rings > ';rings
120 Hanoi rings,1,2,3
130 :
140 DEFine PROCedure Hanoi(r,peg_a,peg_b,peg_c)
150 IF r = 0 THEN RETurn
160 Hanoi r-1,peg_a,peg_c,peg_b
170 PRINT'Move ring ';r;' from peg ';peg_a;' to peg ';peg_b
180 Hanoi r-1,peg_c,peg_b,peg_a
190 END DEFine Hanoi
- badaman
- Sabreman
- Mensajes: 499
- Registrado: Mar Ene 29, 2008 10:58 am
- Contactar:
Re: PROCedimientos y FuNciones
Sería muy interesante si, en unas líneas generales, expusieras el funcionamiento de la rutina para la resolución de sudokus que creaste para el juego OSUSQ.
Ese es un estupendo ejemplo del uso de la recursividad en un programa.
Ese es un estupendo ejemplo del uso de la recursividad en un programa.
Sinclair QL, la respuesta profesional de los 80
-
- Sabreman
- Mensajes: 396
- Registrado: Dom Feb 24, 2008 10:56 pm
Re: PROCedimientos y FuNciones
badaman escribió:Sería muy interesante si, en unas líneas generales, expusieras el funcionamiento de la rutina para la resolución de sudokus que creaste para el juego OSUSQ.
El procedimiento de resolución del sudoku en el juego usa la recursividad para su resolución y concretamente un algoritmo clásico llamado backtracking, que es básicamente un algoritmo recursivo pero con vuelta atrás para retomar otro "camino" diferente en caso de no encontrar una solución. Es un algoritmo de "fuerza bruta", es decir explora "a lo bestia" todas las posibilidades. No es un algoritmo muy óptimo pero funciona. (El que se implementa aquí creo que se podría optimizar intentando evitar comprobaciones innecesarias, aunque no sé si el coste final sería menor).
Por simplicidad he extraído el siguiente código del juego que genera la solución empleando dicho algoritmo recursivo. En este caso es el la FuNction Generar().
Esta función emplea tres parámetros, el primero es un array de 9x9 de enteros que contiene el planteamiento del sudoku a resolver (el valor 0 en una posición es un hueco vacío), valores <> 0 indican números del planteamiento del problema. Los dos parámetros siguientes son fila, columna donde empezará la búsqueda (1,1 en la primera llamada).
Lo que hace la función básicamente es empezar a rastrear la matriz y buscar un hueco (donde haya un valor 0). Luego intentar buscar en ese hueco el primer valor válido (de 1 a 9 cumpliendo las relgas del sudoku, esto es, que el valor no se repita en la fila, columna o sección). Aquí usa una rutina de apoyo que no está en este trozo de código por simplicidad, dicha función es obvia (ver código del juego para detalle de esas rutinas, ValidaNumero()).
A partir de este punto la función llega la sección crítica, si encuentra un valor válido avanza llamándose a si misma pero con la búsqueda de un nuevo hueco. Si no encuentra un valor válido en este punto (fila, columna) debe retroceder a la llamada anterior para intentarlo con el siguiente valor (de la llamada anterior), es decir "otro camino".
La condición de parada es que se llegue a la última posición del array (posición 9,9) y que en dicha posición se encuentre un valor válido. Entonces el sudoku tendrá solución, si no es así entonces NO habrá solución. Podría pasara también que el programa agotara todas las valores en todas las retroceda sin encontrar solución.
Bueno .... no sé si me he enrollado mucho, el extracto de código es el siguiente y como dice badaman es un buen ejemplo de la potencia de la recursividad:
Código: Seleccionar todo
3540 REMark ...
3610 :
3620 solucion% = Generar (sk%, 1, 1)
3630 :
3650 IF solucion% <> 0 THEN
3660 Mensaje "³³ EL SUDOKU TIENE SOLUCI–N !!", 1
3670 ELSE
3680 Mensaje "³³ JOOOPP EL SUDOKU NO TIENE SOLUCI–N !!", 1
3690 END IF
3700 :
3710 :
3740 REMark --- Funci–n recursiva (tipo backtracking) para solucionar el sudoku
3750 DEFine FuNction Generar(sk%, fil, col)
3760 LOCal num%: LOCal res%
3770 LOCal f, c
3780 LOCal sol%
3790 :
3800 REMark Avanzar hasta encontrar una posici–n libre
3810 REPeat BuscaHueco
3820 IF fil > 9 OR col> 9 THEN sol%=1: RETurn sol%
3830 IF sk%(fil,col) = 0 THEN
3840 EXIT BuscaHueco
3850 END IF
3860 col = col + 1
3870 IF col > 9 THEN
3880 col = 1
3890 fil = fil + 1
3900 END IF
3910 END REPeat BuscaHueco
3920 :
3930 sol% = 0
3940 num% = 0
3950 REMark Rastrear todos los n™meros del sudoku del 1 al 9
3960 REPeat BuscaNumero
3970 num% = num% + 1
3980 res% = ValidaNumero(sk%, num%, fil, col)
3990 REMark PRINT#0, num%;res%: INPUT#0, "> ";b$
4000 IF res% <> 0 THEN
4010 sk%(fil,col) = num%
4020 PintaCasilla num%, fil, col, 0
4030 f = fil
4040 c = col + 1
4050 IF c > 9 THEN
4060 f = f + 1
4070 c = 1
4080 END IF
4090 REMark Llamada recursiva si llega al final
4100 REMark estamos en la condici–n de parada
4110 IF f < 10 THEN
4120 sol% = Generar (sk%, f, c)
4130 ELSE
4140 sol% = 1
4150 END IF
4160 END IF
4170 IF sol% = 1 OR num% = 9 THEN
4180 EXIT BuscaNumero
4190 END IF
4200 END REPeat BuscaNumero
4210 :
4220 IF sol% = 0 THEN
4230 sk%(fil,col) = 0
4240 PintaCasilla 0, fil, col, 0
4250 END IF
4260 RETurn sol%
4270 END DEFine
4280 :
4290 :
-
- Sabreman
- Mensajes: 396
- Registrado: Dom Feb 24, 2008 10:56 pm
Re: PROCedimientos y FuNciones
Colección de rutinas para detectar el "hardware" del QL.
Autor: J.D.Mitchell.
Autor: J.D.Mitchell.
Código: Seleccionar todo
10000 REMark *****************************
10010 REMark Version: V1.0
10020 REMark Date: 20/Sep/1997
10030 REMark Author: J.D.Mitchell
10040 REMark EMAIL: Jack@home9999.demon.co.uk
10050 REMark Change: 1) Default system vars base is at 160K not 128K
10060 REMark 2) Add change control header
10070 REMark *****************************
10080 REMark Version: 1.1
10090 REMark Date: 20/Sep/1997
10100 REMark Author: J.D.Mitchell
10110 REMark EMAIL: Jack@home9999.demon.co.uk
10120 REMark Change: 1) Use peek(!!addr) etc. when possible
10130 REMark *****************************
10140 REMark Version: 1.2
10150 REMark Date: 28/Nov/1997
10160 REMark Author: J.D.Mitchell
10170 REMark EMAIL: Jack@home9999.demon.co.uk
10180 REMark Change: 1) Corect error in change history
10190 REMark Change: 2) Report QDOS versions as ROM names not versions
10200 REMark *****************************
10210 DEFine FuNction DISPLAY_WIDTH
10220 IF os$='SMSQE' THEN RETurn SCR_XLIM
10230 RETurn scr__lim%('scr_','x256a0x0')&&-2
10240 END DEFine
10245 :
10250 DEFine FuNction display_height
10260 IF os$='SMSQE' THEN RETurn SCR_YLIM
10270 RETurn scr__lim%('scr_512x','a0x0')
10280 END DEFine
10285 :
10290 DEFine FuNction scr__lim%(prefix$,sufix$)
10300 LOCal h_max%,h_min%,h%,loop
10310 h_max%=1280
10320 h_min%=256
10330 REPeat loop
10340 h%=(h_max%+h_min%+1)DIV 2
10350 IF h%>h_max% THEN h%=h_max%
10360 IF FTEST(prefix$&h%&sufix$)=0 THEN
10370 h_min%=h%
10380 ELSE
10390 h_max%=h%-1
10400 END IF
10410 IF h_min%=h_max% THEN RETurn h_max%
10420 END REPeat loop
10430 END DEFine
10435 :
10440 REMark mimics peek_w(!!addr)
10450 DEFine FuNction peek_w_sys(addr)
10460 IF os$='QDOS' THEN
10470 RETurn PEEK_W(addr+sys_vars_base)
10480 END IF
10490 RETurn PEEK_W(!!addr)
10500 END DEFine
10505 :
10510 REMark mimics peek(!!addr)
10520 DEFine FuNction peek_sys(addr)
10530 IF os$='QDOS' THEN
10540 RETurn PEEK(addr+sys_vars_base)
10550 END IF
10560 RETurn PEEK(!!addr)
10570 END DEFine
10575 :
10580 REMark mimics peek_l(!!addr)
10590 DEFine FuNction peek_l_sys(addr)
10600 IF os$='QDOS' THEN
10610 RETurn PEEK_L(addr+sys_vars_base)
10620 END IF
10630 RETurn PEEK_L(!!addr)
10640 END DEFine
10645 :
10650 DEFine PROCedure setup_read
10660 LOCal hardware_code,cpu_code,display_code,sys_vars_base,monitor_code,display_register
10670 IF VER$<>'HBA' THEN
10680 IF VER$='JSL1' THEN
10690 os$='Minerva'
10700 version$=VER$(1)
10710 sys_vars_base=VER$(-2)
10720 lang$='GB'
10730 ELSE
10740 os$='QDOS'
10750 version$=VER$
10760 sys_vars_base=(128+32)*1024
10770 IF LEN(version$)<=2 THEN
10780 lang$='GB'
10790 ELSE
10800 lang$=version$(3 TO)
10810 END IF
10820 END IF
10830 ELSE
10840 IF FTEST('history_1024')<>0 THEN
10850 os$='SMSQ'
10860 ELSE
10870 os$='SMSQE'
10880 END IF
10890 sys_vars_base=VER$(-2)
10900 version$=VER$(1)
10910 lang$=LANGUAGE$
10920 END IF
10930 REMark mimics PROCESSOR provided by SMSQE
10940 cpu_code=(peek_sys(161) DIV 16)*10
10950 REMark mimics MACHINE provided by SMSQE
10960 hardware_code=peek_sys(167)&&31
10970 REMark mimics DISP_TYPE provided by SMSQE but gives 6 for VGA on a QXL
10980 display_code=peek_sys(167) DIV 32
10990 display_register=peek_sys(52)
11000 freq=peek_w_sys(168)
11010 SELect freq
11020 =50,60
11030 =REMAINDER :freq=50
11040 END SELect
11050 ram_top=peek_l_sys(32)
11060 monitor_code=peek_sys(50)
11070 REMark Convert to text
11080 SELect ON hardware_code
11090 =0:hardware$='Standard QL'
11100 =1:hardware$='Atari'
11110 =2,3:hardware$='Mega/RTC ST'
11120 =4,5:hardware$='Stacy'
11130 =6,7:hardware$='STE'
11140 =8,9:hardware$='Mega STE'
11150 =10,11:hardware$='GOLD card'
11160 =12,13:hardware$='Super Gold card'
11170 =16:hardware$='Falcon'
11180 =24:hardware$='TT 030'
11190 =28:hardware$='QXL'
11200 =30:hardware$='QPC'
11210 =31:hardware$='QLAY'
11220 =REMAINDER :hardware$='Unknown HW('&hardware_code&')'
11230 END SELect
11240 SELect hardware_code
11250 =1,3,5,7,9:add_on$='Blitter'
11260 =11,13:add_on$='Hermes'
11270 =REMAINDER :add_on$=''
11280 END SELect
11290 SELect ON monitor_code
11300 =0:monitor$='Monitor'
11310 =1:monitor$='625 line TV'
11320 =2:monitor$='525 line TV'
11330 =REMAINDER :monitor$='Unknown Monitor('&monitor_code&')'
11340 END SELect
11350 display_mode=4+(display_register&&8)DIV 2
11360 display_page=display_register DIV 128
11370 SELect display_code
11380 =0:display$='Standard'
11390 =1:display$='Monochrome'
11400 =2:display$='Extended 4 emulator'
11410 =4:display$='QMVE'
11420 =5:display$='Aurora'
11430 =6:display$='VGA'
11440 =REMAINDER :display$='Unknown display('&display_code&')'
11450 END SELect
11460 SELect cpu_code
11470 =0:cpu$='68000/68008'
11480 =10:cpu$='68010'
11490 =20:cpu$='68020'
11500 =30:cpu$='68030'
11510 =40:cpu$='68040'
11520 =REMAINDER :cpu$='Unknown CPU('&cpu_code&')'
11530 END SELect
11540 END DEFine
11545 :
11550 DEFine PROCedure setup_show(chan%)
11560 PRINT#chan%,'Running ';os$;
11570 IF os$=='QDOS' THEN
11580 PRINT#chan%,' ';version$;' ROM'
11590 ELSE
11600 PRINT#chan%,' V';version$
11610 END IF
11620 PRINT#chan%,'On a ';cpu$;' powered ';hardware$
11630 PRINT#chan%,'With ';INT(ram_top/1024)-128;'KByte RAM';
11640 IF add_on$<>'' THEN PRINT#chan%,' and ';add_on$
11650 PRINT#chan%,\'Using ';display$;' ';DISPLAY_WIDTH;'x';display_height;' on a ';monitor$
11660 PRINT#chan%,'Displaying ';position_name$(display_page+1);' page in mode ';display_mode
11670 PRINT#chan%,'Country ';lang$;' @';freq;'Hz'
11680 END DEFine
11685 :
11690 DEFine FuNction position_name$(n)
11700 SELect n
11710 =1:RETurn '1st'
11720 =2:RETurn '2nd'
11730 =3:RETurn '3rd'
11740 =REMAINDER :RETurn n&'th'
11750 END SELect
11760 END DEFine
11765 :
11770 DEFine PROCedure setup_test
11780 TK2_EXT
11790 setup_read
11800 CLS
11810 setup_show #1
11820 END DEFine
11825 :
11830 setup_test
- badaman
- Sabreman
- Mensajes: 499
- Registrado: Mar Ene 29, 2008 10:58 am
- Contactar:
Re: PROCedimientos y FuNciones
Si se conoce la altura y anchura de una ventana y la escala vertical, podemos predecir cuantos puntos en el sistema de coordenadas horizontal serán visibles dentro de la ventana en cuestión. Es decir, cuantos puntos de ancho mide la ventana. (estos puntos, por la escala aplicada, no se corresponden con los pixels reales de pantalla)
La siguiente función devuelve este valor:
La siguiente función devuelve este valor:
Código: Seleccionar todo
1000 DEFine FuNction X_Scale(y_scale,wide,high)
1010 RETurn 0.75 * y_scale * wide / high
1020 END DEFine X_Scale
Sinclair QL, la respuesta profesional de los 80
¿Quién está conectado?
Usuarios navegando por este Foro: No hay usuarios registrados visitando el Foro y 37 invitados